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ABSTRACT 


A  compiler  for  a  subset  of  the  Automated  Data  Processing 
Equipment  Selection  Office  (ADPESO),  HTPO-COBOL,  has  been 
implemented  on  a  microcomputer.  The  implementation  provides 
nucleus  level  constructs*  interprogram  communications*  and 
file  options  from  the  ANSI  COBOL  package  along  with  the 
PERFORM  UNTIL*  PERFORM  VARYING  and  an  enhanced  version  of 
the  IP-THEN-ELS E  construct  that  includes  nesting  and 
multiple  program  statements  for  both  the  THEN  and  ELSE 
clauses.  These  additional  constructs  from  level  two  of  ANSI 
COBOL  provide  for  more  flexibility  and  increased  structural 
control.  The  language  was  implemented  through  a  compiler  and 
run-time  package  executing  under  the  CP/M  operating  system 
of  a  Z -80  or  an  6080  microcomputer-based  system.  Both  the 
compiler  and  interpreter  can  be  executed  in  20K  bytes  of 
main  memory.  A  program  consisting  of  5K  bytes  of  symbol 
table  entries  can  be  supported  on  this  size  machine. 
Modification  of  the  compiler  and  Interpreter  programs  can  be 
accomplished  to  take  advantage  of  larger  machines.  The 
programs  that  make  up  the  compiler  and  interpreter  package 
require  50K  bytes  of  disk  storage. 


4 


Si**:-*".*'"'- 


TABLE  OF  CONTENTS 


X.  INTRODUCTION  .  8 

A.  BACKGROUND  .  8 

B.  OPERATING  ENVIRONMENT  .  10 

C.  GOALS  AND  OBJECTIVES  .  10 

D.  PROBLEM  DEFINITION  .  11 

E.  PROBLEM  SOLUTION  .  11 

F.  STSTEM  OVERVIEW  .  13 

II.  NPS  MICRO-COBOL  COMPILER  .  16 

A.  GENERAL  DESCRIPTION  .  16 

B.  SYMBOL  TABLE  .  16 

1.  Numeric  Values  .  20 

2.  Numeric  Edit  .  20 

3.  Alpha  or  Alphanumeric  .  25 

4.  Alpha  Edit  .  25 

5.  Tables  .  27 

6.  Labels  .  27 

7.  ▼lies  .  30 

8.  Records  .  30 

C.  COMPILEP  MODULE  "PART  ONE"  .  33 

1.  Purpose  .  33 

2.  Control  Actions  .  33 

3.  Symbol  Table  Entries  .  37 

4.  Intermediate  Code  Generation  .  38 

5.  Parser  Actions . . .  39 


5 


D.  INTERFACE  ACTIONS  . 

E.  COMPILER  MODULE  "PART  TWO 


III. 


IP. 


V. 


1.  Purpose  . 

2.  Control  Actions  . 

3.  Symbol  Table  Entries  . 

4.  Intermediate  Code  Generation 

5.  Parser  Actions  . 

NPS  MICRO-COBOL  INTERPRETER  . 

A.  GENERAL  DESCRIPTION  . 

B.  MEMORY  ORGANIZATION  . 

C.  INTERPRETER  INTERFACE  . 

D.  PSEUDO-MACHINE  INSTRUCTIONS  ... 

1.  Format  . 

2.  Arithmetic  Operations  . 

3.  Branching  . 

4.  Moves  . 

5.  Input-Output  . 

6.  Subroutine  Instructions  ... 

7.  Special  Instructions  . 

STSTEM  DEBUGGING  METHODS  AND  TOOLS 

A.  DEBUGGING  METHODOLOGY  . 

B.  INTERACTIVE  TOOLS  . 

C.  CROSS  REFERENCE  LISTINGS  . 

D.  VALIDATION  TESTS  . 

CONCLUSIONS  AND  RECOMMENDATIONS  ... 


APPENDIX  A -NPS  MICRO-COBOL  USER'S  MANUAL 


APPENDIX  B-LIST  OP  MICRO-COBOL  RESERVED  WORDS  .  15? 

APPENDIX  C -MICRO-COBOL  EXECUTION  PROCEDURES  .  159 

APPENDIX  D-PART  ONE  AND  PART  TWO  INTERNAL  DATA  STRUCTURES 

AND  SIGNIFICANT  VARIABLES  .  165 

APPENDIX  E-MACHINE  DEPENDENT  VARIABLES  .  1?5 

APPENDIX  F-MICRO-COBOL  PARSE  TABLE  GENERATION  .  177 

APPENDIX  G-LIST  OF  INOPERATIVE  CONSTRUCTS  .  179 

APPENDIX  H-IBM  TO  MICROCOMPUTER  TRANSFER  PROCEDURES  .  160 

APPENDIX  I -DEBUGGING  NPS  MICRO-COBOL  USING  SID  .  182 

COMPUTER  LISTINGS  . ie4 

PART  ONE  .  184 

PART  TWO  .  226 

INTERP  .  270 

READER  .  309 

BUILD  . 311 

INTRDR  .  320 

DECODE  .  321 

GRAMMFR  .  327 

PART  ONE  .  327 

PART  TWO  .  330 

LIST  OF  REFERENCES  .  334 

INITIAL  DISTRIBUTION  .  336 


I.  INTRODUCTION 


A.  BACKGROUND 

The  NPS  HICRO-COBOL  Compiler/Interpreter  was  Initially 
(1976)  [3]  developed  to  demonstrate  that  it  was  feasible  to 
implement  a  COBOL  compiler  on  a  microcomputer.  It  was  known 
that  the  COBOL  language  used  would  have  to  be  a  subset  of 
ANSI  COBOL  because  of  the  restriction  imposed  by  the  size  of 
a  microcomputer  memory.  A  subset  of  ANSI  COBOL,  specifically 
the  Navy's  Automated  Lata  Processing  Equipment  Selection 
Office  UDPESO)  HYP0-C030L  [4],  was  selected  as  the  basis 
for  the  implementation.  Additional  motivation  was  provided 
by  the  DOD  requirement  that  all  computers  used  in  a 
non-tactical  environment  be  capable  of  executing  COBOL 
programs. 

The  previous  work  was  directed  toward  six  major  areas: 
1.)  selecting  a  suitable  COBOL  subset  to  operate  on,  2.) 
developing  the  associated  grammar  for  the  language,  3.) 
determining  what  type  of  compiler  to  design,  4.)  designing 
and  coding  the  compiler,  5.)  designing  and  coding  the 
interpreter,  and  6.)  testing  and  debugging  of  the  storage 
allocation  and  symbol  table  entries  of  the  compiler. 

The  choice  of  a  suitable  language  was  originally  based 
on  BTPO-COBOL,  since  this  is  a  Department  of  the  Navy 
approved  subset  of  COBOL,  designed  to  place  minimal 


requirements  on  a  system  for  compiler  supoort.  Where 
possible,  short  constructs  were  used  in  the  place  of  longer 
ones.  Where  more  than  one  reserved  word  served  the  same 
function  in  COBOL  the  shortest  form  was  used.  There  is  no 
optional  verbage  in  the  language,  and  no  duplicate 
constructs  perform  the  same  function.  Limits  were  placed  on 
all  statements  that  had  a  variable  input  format  so  that  all 
statements  had  a  fixed  maximum  length.  Where  possible,  such 
constructs  were  removed  completely  from  the  language.  In 
addition,  user  defined  identifier  names  were  limited  to 
twelve  characters  to  reduce  symbol  table  storage 
requirements. 

Father  than  include  the  standard  levels  of 
implementation  for  all  of  the  modules  in  ETPO-COBOL, 
constructs  were  included  only  as  required.  In  addition  to 
low  level  constructs,  THE  PERFORM  UNTIL  was  included  to 
allow  better  program  structure.  Further  Justification  for 
the  manner  of  subsetting  and  a  highly  detailed  description 
of  each  element  of  the  language  is  contained  in  the 
HYPO-COBOL  language  specifications  reference  3. 

The  grammar  for  the  MICRO-COBOL  language  was  defined  as 
LALR(l).  The  compiler  design  was  based  on  a  table-driven 
parser  for  the  LALR(l)  grammar.  The  algorithm  used  to 
develope  the  parse  tables  for  the  compiler  was  developed  by 
W.  R.  Lalonge  [20]. 

The  basic  design  and  coding  of  the  compiler  and 


interpreter  was  completed  prior  to  the  current  thesis  work 
by  Scott  Allan  Craig  [3].  Modification  to  the  original 
thesis  worlc  was  conducted  by  Phil  Mylet  [18].  Initial 
testing  and  debugging  of  Part  One  was  conducted  by  Jim 
Parlee  and  Michael  Rice[9] . 

3.  OPERATING  ENVIRONMENT 

The  NPS  MICRO-COBOL  compiler  and  interpreter  are 
designed  to  run  under  the  CP/M  operating  system  on  an  8080 
or  Z80  based  microcomputer  with  at  least  20K  bytes  of  main 
memory.  The  compiler  programs  are  designed  to  use  no  more 
than  14K  bytes  of  main  memory,  while  the  interpreter  program 
uses  approximately  12E  bytes.  The  compiler  and  interpreter 
require  50K  bytes  of  disk  storage  for  the  programs  that  make 
up  the  compiler/interpreter  package.  For  information  on 
creating  MICRO-COBOL  source  programs  and  CP/M  see  references 
5  and  6. 

C.  GOALS  AND  OBJECTIVES 

The  major  goals  of  this  work  were  1.)  Modify  the 
existing  compiler  to  allow  use  of  the  ADPESO  validation  test 
programs,  2.)  Correct  all  known  errors  as  outlined  by  Farlee 
and  Rice[18l,  3.)  Implement  all  constructs  not  previously 
Implemented,  4.)  Verify  that  NPS  MICRO-COBOL  met  HTPO-COBOL 
standards,  and  5.)  Extend  the  existing  compiler/interpreter 
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package  with  some  of  the  more  frequently  used  high  level 
COBOL  constructs. 

In  addition  to  the  above  goals,  it  was  considered 
beneficial  to  update  and  incorporate  all  previous 
documentation  into  the  present  NPS  MICRO-COBOL 
compiler/interpreter  documentation.  This  documentation  is 
included  in  this  thesis. 

D.  PROBLEM  DEFINITION 

For  software  performance  assessment,  a  series  of  simple 
COBOL  source  programs  and  the  Navy  ADPESO  FYPO-COBOL  [4l 
validation  test  programs  (HCCVS )  were  compiled  and  execution 
was  attempted.  Initial  results  of  the  ADPESO  validation  test 
programs  produced  over  400  compile  and  run  time  errors.  Some 
of  the  errors  were  known  previously  as  outlined  in  the 
previous  thesis  work  by  Farley  and  Rice[9],  The  elimination 
of  these  problems  plus  the  goals  outlined  above  formed  the 
foundation  for  this  thesis. 

E.  PROBLEM  SOLUTION 

The  ADPESO  validation  test  programs  could  cot  be  used 
for  testing  the  compiler/interpreter  until  three  areas  were 
corrected.  1.)  File  I/O  was  Inadequate  to  generate  usable 
intermediate  code,  2.)  the  IF-THEN-ELSE  construct  would  not 
allow  multiple  statements  to  be  performed,  and  3.)  the  Move 
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Numeric  Edited  command  was  not  implemented.  The  file  I/O 
problem  was  corrected  by  Doug  Loskot[15]  as  a  class  project 
early  in  this  thesis  effort.  A  new  IF-THEN-*”SE  construct 
allowing  the  use  of  multiple  statements  in  both  the  "THEN" 
and  "ELSE"  clauses  was  implemented  by  Robert  Hartel  and  Doug 
Stowers  [19]  as  another  class  project.  Implementation  of  the 
Move  Numeric  Edited  command  was  completed  by  the  author 
early  in  the  thesis  effort  and  allowed  the  validation  test 
programs  to  be  used  for  testing. 

Once  the  validation  programs  could  be  compiled  and 
executed,  testing  and  debugging  continued  at  a  more  rapid 
pace.  All  the  errors  exposed  by  the  test  programs  as  well  as 
the  known  errors  outlined  in  Appendix  G  of  Farlee  and 
Rlce[9]  were  corrected,  with  the  exception  of  the  tests 
dealing  with  the  Interprogram  Communication  Module. 

The  grammer  in  Part  Two  of  the  compiler  was  not 
constructed  to  allow  the  name  of  a  called  program  to  be 
stored.  This  required  a  change  to  the  existing  grammar.  In 
addition  to  modiflng  the  grammar  for  subroutine  calls,  a 
change  to  allow  nesting  IF-THEN-ELSE ,  NEXT  SENTENCE  option, 
the  PERFORM  VARYING  verb,  the  COMPUTE  verb  and  the  logical 
operators  "AND"  and  "OR"  were  defined  in  the  grammar. 

The  grammar  change  was  Implemented  in  two  steps.  First 
the  IF-THEN-ELSE  statement,  which  included  nesting  and  an 
IND-IF  clause,  and  the  PERFORM  VARYING  statement  was 
Implemented  as  a  class  project  by  Carol  Cagle [2].  The 
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present  grammer  is  the  result  of  the  second  change  and 
includes  the  COMPUTE  verb,  logical  operators,  GIVING  clause 
for  the  arithemetic  operators  and  the  change  that  enabled 
implementation  of  the  Interprogram  Communications  module.  In 
it's  present  form  all  of  the  specifications  of  RYPO-COBOL 
are  met  or  exceeded.  In  addition  to  the  constructs 
previously  mentioned  the  new  grammar  will  be  able  make  the 
environment  division  optional,  handle  null  paragraphs 
(paragraphs  with  no  statements)  and  multiple  open,  close, 
display,  add,  and  subtract  statements  as  well  as 
multi-dimensional  tables.  Appendix  G  contains  a  list  of 
constructs  that  have  been  defined  in  the  grammar  but  not  yet 
implemented . 

F.  SYSTEM  OVERVIEW 

NPS  MICRO-COBOL  is  a  compiler/interpreter  package.  The 
compiler  consists  of  three  modules  that  combine  to  produce 
two  files.  The  first  file  is  an  intermediate  code  file  and 
the  second  is  a  list  file  containing  any  compilation  errors 
and  the  line  that  caused  the  error.  The  first  and  second 
modules  are  combined  together  to  form  a  module  called 
COBOL.COM.  The  command  COBOL  <file  name>  initiates  the 
compilation  sequence.  The  first  module  (PART  I)  opens  the 
input  file,  list  file  and  code  file,  moves  the  second 
module,  READER,  to  high  memory  for  later  use,  and  then 


starts  compiling  the  input  file  through  the  word  PROCEDURE 
in  the  sentence  PROCEDURE  DIVISION .  The  symbol  table  is 
built  starting  at  a  storage  location  Just  above  PART  I  and 
can  use  all  available  memory  up  to  the  base  of  the  READER 
routine  previously  moved  to  high  memory.  After  PPOCEDURF  is 
parsed  control  is  tracsfered  to  the  READER  routine  which 
then  copies  the  third  module  (PART  II),  into  memory  over 
PART  I.  Compilation  continues  to  the  end  of  the  input  file 
using  the  symbol  table  constructed  from  PART  I,  The  symbol 
table  can  be  added  to  by  PART  II  up  to  and  including  the 
area  previously  used  by  the  READER  routine  as  REATER  is  no 
longer  needed.  This  scheme  allows  the  use  of  all  available 
free  memory  for  the  symbol  table.  At  the  end  of  the  input 
file  all  files  are  closed  and  the  compilation  process  is 
complete. 

Error  recovery/management  is  accomplished  using  the  ad 
hoc  panic  mode  technique  discussed  in  Aho  and  Ullman  [1] . 
Errors  are  ancouced  to  the  user  by  a  two  letter  code.  The 
user  is  required  to  look  up  the  meanings  of  these  codes  in 
order  to  understand  the  full  significance  of  each  error  but 
it  was  felt  that  this  technique  was  necessary  to  keep  the 
sise  of  the  compiler/interpreter  package  to  a  minimum. 

The  command  EXEC  <file  name>  causes  the  load  routine 
BUILD  to  be  loaded  into  memory.  The  BUILD  routine  opens  the 
intermediate  file  created  by  the  first  phase  and  sets  up  the 
core  image  of  the  pseudo  machine.  Control  transfers  to  the 
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INTRDR  routine  (Interpreter  Reader)  which  reads  the  third 
module  CINTERP  Into  memory.  This  Is  the  Interpreter  and  once 
loaded  control  Is  passed  to  It  and  program  execution  begins. 


II.  UPS  MICR0-C030L  COMPILER 


A.  GENERAL  DESCRIPTION 

The  MICRO-COBOL  compiler  is  a  one  pass  compiler  that 
scans  and  parses  MICRO-COBOL  source  programs,  and  generates 
intermediate  code  (pseudo-instructions)  for  the  interpreter 
(pseudo-machine).  The  scanner  design  is  similar  to  most 
other  scanner  Implementations.  The  parser  is  an  LALR(l) 
table-driven  design,  implemented  in  the  PLM80  programming 
language  [10].  The  parse  tables,  as  stated  before,  were 
generated  using  an  algorithm  developed  at  the  University  of 
Toronto  [20]. 

The  compiler  reads  the  source  program  from  a  disk  file, 
extracts  the  needed  information  for  the  symbol  table  and 
writes  pseudo-instructions  to  an  intermediate  code  file.  To 
accomplish  this  function,  the  compiler  consists  of  three 
modules:  PART  ONE,  READEP,  and  PART  TWO. 

B.  SYMBOL  TABLE 

The  symbol  table  Is  the  key  data  structure  in  the 
compiler.  Information  concerning  identifiers,  files,  and 
records  specified  in  the  DATA  DIVISION  of  the  MICRO-COBOL 
source  program  is  stored  in  the  symbol  table,  along  with 
labels  specified  in  the  PROCEDURE  DIVISION. 

The  symbol  table  structure  consists  of:  1.)  a  sixty-four 
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address  hash  table,  2.)  a  fixed  length  field  of  fourteen 
bytes  for  each  symbol  table  entry,  and  3.)  a  variable  length 
field  to  hold  the  name  of  each  identifier.  Since  each 
identifier  name  is  limited  to  fifteen  ASCII  characters  the 
symbol  table  entry  for  identifiers  can  vary  in  length  from 
fourteen  to  twenty-nine  bytes.  The  bytes  of  each  symbol 
table  entry  are  grouped  into  various  fields  of  either  one  or 
two  bytes  depending  on  the  storage  requirements.  The 
fourteen  bytes  of  the  fixed  length  field  entry  are  numbered 
from  zero  to  thirteen  and  the  variable  length  field  begins 
with  byte  fourteen.  In  referencing  a  specific  field  a  byte 
index  with  a  value  from  zero  to  fourteen  is  utilized. 

The  symbol  table  entry  for  a  single  identifier  could 
contain  up  to  nine  different  attributes  of  that  identifier, 
although  not  all  identifiers  required  the  full  range  of 
attributes.  The  various  fields  in  the  symbol  table  contained 
different  information  depending  on  whether,  for  example,  an 
identifier  was  a  numeric  or  alphanumeric  type.  Four  of  the 
fields  contained  the  same  information  for  all  identifiers. 
These  fields  were:  1.)  field  zero  (bytes  zero  and  one  ) 
contained  the  collision  link,  2.)  field  one  (byte  two) 
contained  the  type  of  the  identifier,  3.)  field  two  (byte 
three)  contained  the  length  of  the  identifier  name,  and  4.) 
field  thirteen  (byte  fourteen)  was  the  beginning  of  the 
ASCII  character  representation  for  the  identifier  name.  It 
should  be  noted  that  an  identifier  of  type  FILLER  would  not 
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have  a  name  associated  with  it,  so  field  two  would  contain  a 
zero  and  field  fourteen  would  not  exist. 

Entry  into  the  symbol  table  is  accomplished  by  using  a 
HASH  function  on  the  ASCII  character  representation  of  the 
Identifier  name.  This  function  generates  an  even  number 
between  zero  and  126.  The  number  is  used  as  an  index  into 
the  hash  table  by  specifying  an  offset  from  the  base  of  the 
hash  table.  The  hash  table  can  hold  sixty-four  uniquely 
determined  address  references  to  identifiers.  The  hash  table 
entry  associated  with  each  index  reference  heads  a  linked 
list  of  identifiers  with  the  same  EASE  function  value.  The 
linked  list  structure  provides  for  additional  identifier 
storage  and  therefore  the  number  of  unique  identifiers  is 
not  limited  by  the  sixty-four  index  values  generated  by  the 
HASH  function.  A  zero  entry  in  the  bash  table  indicates  that 
there  is  no  identifier  with  that  HASH  function  value.  In 
tracing  through  the  linked  list  of  identifiers  the  most 
recently  declared  variable  appears  at  the  end  of  the  list. 
See  figure  [I I— 1 ]  for  an  example  of  the  computation  of  a 
hash  value.  See  figure  ClI-2]  for  an  example  of  the  hash 
table  indexing  and  linking  of  hash  values. 
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HASH  VALUE  COMPUTATION 


HASH  Junction  value:  sun  of  identifier  ASCII  characters 
logically  and  with  3FH  then  shifted  left  (SHL)  one  hit. 
HASHBASE  *  2000H 

H.F.(AB)  *  HASHBASE  +  SHL(((41H  +  42E)  AND  3FH),1)  =  2006H 
H.F.(BA)  =  HASHBASE  +  SHL(((42H  +  41H)  AND  3FH),1)  =  2006H 

FIGURE  II-l 


FASH  TABLE,  SYMBOL  TABLE  LINKING 


HASH  SYMBOL 

TABLE  TABLE 


s - 

- {  2128H 

i  i 

1  ■■  | 

I 

!  collision! 

{ 

- j  2126H 

!  link  for  ! 

! 

!  "BA"  ! 

1 - 

- 1  2124H 

j  - — - —  | 

2200H 


I 


- 1  2008H 

21F0H  I  » - > 

- j  2006H 


| - 1  2C00H 


!  collision! 

!  lin|  for  !  » — 

!  "AB  ! 

j - j  21F0H 


FIGURE  I 1-2 


1.  Numeric  Values 


The  symbol  table  entry  for  numeric  values  can 
contain  up  to  eight  attributes  of  the  variable.  These 
attributes  are:  1.)  Identifier  type,  2.)  length  of  variable 
name  3.)  beginning  address  of  variable  storage,  4.)  numeric 
count  (number  of  storage  locations  required  by  the 
identifier),  5.)  level  number,  6.)  number  of  digits  to  the 
right  of  the  decimal  point,  7.)  the  variable  name,  end  8.)  a 
previous  occurs  pointer.  The  previous  occurs  pointer  is 
appended  after  the  identifier  name  only  if  needed.  Since 
most  declarations  will  not  require  the  use  of  this  pointer, 
a  saving  of  three  bytes  per  variable  declaration  is 
realized.  It  was  felt  that  the  increase  in  the  total  number 
of  variables  that  could  be  declared  in  a  given  memory  size 
outweighed  the  Increased  complexity  in  symbol  table  access 
time.  Figures  [I 1—33  and  [II-4]  illustrate,  respectively, 
the  following  two  COBOL  declarations: 

01  N0M  PIC  9(9). 

02  NUM  PIC  9(6)V999  OCCURS  12. 

2,  Numeric  fdtt 

The  numeric  edit  symbol  table  entry  expands  on  the 
numeric  symbol  entry  and  utilizes  bytes  eight  and  nine  to 
hold  the  beginning  address,  in  the  constants  area,  of  the 
edit  field  mask.  This  mask  allowed  for  the  insertion  of  the 


following  characters  Into  the  output  display  of  a  numeric 
number:  fixed  and  floating  dollar  signs,  credit(CR)  and 

debit(DB)  signs,  asterisk  fill,  "z"  character  fill,  and  plus 

\ 

(”♦“)  and  minus  signs.  It  should  be  noted  that  an 

identifier  with  a  numeric  edit  field  value  can  not  be  used 
in  an  arithmetic  statement.  Figure  [11—51  illustrates  the 
following  COBOL  declaration: 

01  N0W  PIC  +$ZZZ ,ZZ9 .99 . 


NUMERIC  SYMBOL  TABLE  ENTRY 


BYTE 

SYMBOL  TABLE  VALUE 

0-1 

!  collision  link 

1  (00  00) 

(V 

1  type  identifier 
|  (10) 

M 

!  length  of  identifier 
!  name  (03) 

4-5 

S  beginning  address 
!  of  identifier 

1  storage  (04  25) 

!  length  of  identifier 

S  storage  (09  00) 

6-7 

8-9 

!  not  used 

10 

|  level  entry  (01) 

11 

S  decimal  count  (00) 

12-13 

!  occurances  (00) 

14-16 

j  identifier  name 
i  (4E  55  4D) 

01  NUM  PIC  9(9). 
EIGURE  I I -3 
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NUMERIC  SYMBOL  TABLE  ENTRY  WITH  DECIMAL 
AND  OCCURS  CLAUSE 


BYTE 

SYMBOL  TABLE  YALUE 

i  . .  . 

Si 

1  collision  link 
|  (09  2E) 

(Vi 

I  type  identifier 

1  (10) 
i 

3 

i 

!  length  of  identifier 
!  name  (03) 

4-5 

1  beginning  address 
i  of  identifier  stor- 
S  age  ( 0D  25) 

i ...  . . . . .  .....  .. 

6-7 

i  —  — 

i  length  of  identifier 
!  storage  (09  00) 

8-9 

! 

I* 

2 

3 

S 

_ 

10 

!  level  entry  (02) 

11 

!  decimal  count  (03) 

12-13 

!  occurences  (0C) 

14-16 

1  Identifier  name 
]  (4E  55  4D ) 

17-18 

}  previous  occurs 
!  pointer  00  00 

19  !  dimension  counter 


02  NUM  PIC  9(6) Y999  OCCURS  12. 
FIGURE  I 1-4 
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NUMERIC  STMB01  TABLE  ENTRY  WITH  EDITED  FIELD 


BYTE 

SYMBOL  TABLE  YALUE 

0-1 

!  collslon  link 
!  (09  2E) 

2 

i  type  Identifier 
]  (80) 

W 

i  length  of  Identifier 
!  name  (03) 

4-5 

j  beginning  address 
!  of  Identifier  stor- 
j  age  (0D  25) 

6-7 

!  length  of  identifier 
!  storage  (09  00) 

8-9 

!  beginning  address 
$  of  mask  storage 

1  (25  FE) 

10 

!  level  entry  (01) 

11 

!  decimal  count  (02) 

12-13 

!  occurances  (00) 

14-16  j  Identifier  name 
(4E  55  4D) 


01  NUM  PIC  +$ZZZ , ZZ9.99 . 
FIGURE  I 1-5 
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3.  Alpha  or  Alphanumeric 

The  alpha  and  alphanumeric  symbol  table  entries 
appear  similarly  in  the  symbol  table  except  for  their  type 
fields.  Six  entries  appear  in  the  symbol  table  for  these 
identifiers:  1.)  identifier  type,  2.)  length  of  identifier 
name,  3.)  beginning  address  of  storage,  4.)  number  of 
storage  locations  required  by  the  identifier,  5.)  level 
entry,  and  6.)  identifier  name.  Figure  [11-61  illustrates  an 
alpha  symbol  table  entry  for  the  following  identifier 
declaration: 

01  ALPPA  PIC  A(8). 

4.  Alpha  Edit 

The  alpha  edit  symbol  table  entry  expands  on  tne 
alpha  and  alphanumeric  edit  types  and  utilizes  bytes  eight 
and  nine  to  hold  the  beginning  address  of  the  edit  field 
mask.  These  mask  fields,  which  are  stored  in  the  constants 
area  of  the  pseudo-machine,  contain  the  characters  necessary 
to  edit  an  output  so  that,  for  example,  slashes  or  blanks 
can  be  interspersed  in  the  display  output. 


ALPHA  STMBOL  TABLE  ENTRT 


BITE 


STMBOL  TABLE  VALUE 


0-1 

!  collision  link 
!  (00  00) 

2 

1  type  identifier 

I  (08) 

3 

S  length  of  Identifier 
!  (05) 

4-5 

!  beginning  address 
!  of  identifier 

1  storage  (16  25) 

6-? 

i  length  of  identifier 
|  storage  (08  00) 

e-9 

!  not  used 
• 

10 

!  level  entry  (01) 

11 

!  not  used 

12-13 

1  not  used 

13-17 

!  identifier  name 
}  (41  4C  50  48  41) 

01  ALPHA  PIC  A(8). 
FIGURE  I 1-6 


5 .  Tables 


NPS  PICRO-COBOL  supports  multiply  Indexed  tables  up  to  a 
maximum  of  ten  levels.  The  choice  of  ten  levels  was  based  on 
a  compromise  between  a  single  level  of  HYPO-COBOL  and  49 
levels  proposed  for  the  new  1980  ANSI  COBOL  standard.  The 
limit  of  ten  levels  is  a  restriction  for  HYPO-COBOL  and  the 
nucleus  level  1  constructs  of  ANSI-COBOL.  These  tables  are 
established  by  using  an  OCCURS  clause  with  the  PIC  clause  of 
an  Identifier.  If  an  Identifier  is  specified  as  a  table  the 
number  of  occurances  of  the  table  are  placed  in  byte  twelve 
and  thirteen  of  the  symbol  table  entry  for  that  identifier. 
The  table  identifier  in  COBOL  is  similar  to  the  subscripted 
variable  in  other  programming  languages.  The  previous  occurs 
pointer  shown  in  FIGURE  II-4  is  used  to  indicate  where 
variables  are  located  and  how  many  occurances  exist  to 
enable  the  compiler  to  generate  the  proper  base  address.  For 
example,  the  statement,  ’02  NUM  PIC  9(9)  OCCURS  12”, 
generates  the  symbol  table  entry  illustrated  in  figure 
[11-41. 

6.  Labels 

Labels  generate  the  simplest  of  all  symbol  table 
entries,  only  four  or  five  attributes  are  associated  with 
the  label.  The  variability  depends  on  whether  the  label  is 
declared  in  the  source  program  before  or  after  the  label  is 
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referenced  by  a  GO  or  PERFORM  statement.  In  the  event  that  a 
label  is  specified  before  a  GO  or  PERFORM  statement 
references  it,  the  symbol  table  would  contain  the  following 
1.)  the  type  associated  with  label,  2.)  the  length  of  the 
identifier  name,  3.)  the  address  of  the  first  intermediate 
code  instruction  following  the  appearance  of  the  label  in 
the  source  program  (bytes  four  and  five),  4.)  the  last 
executable  instruction  associated  with  the  label  (bytes 
eight  and  nine)  (This  would  be  either  the  last  executable 
instruction  encountered  before  another  label  or  the  end  of 
the  program),  and  5.)  the  label  name. 

In  the  event  a  label  is  referenced  by  a  GO  or 
PERFORM  statement  before  the  label  actually  appears  in  the 
code,  the  symbol  table  entry  performs  a  different  function 
than  just  indicating  the  beginning  and  ending  of  the 
paragraph  associated  with  the  label.  The  same  symbol  table 
fields  are  used,  however  their  meanings  are  different.  The 
type  is  set  to  that  of  an  unresolved  label (0FFH).  The  label 
remains  unresolved  until  the  beginning  and  the  ending 
addresses  of  the  associated  paragraph  are  determined.  If  a 
label  is  never  resolved  by  the  end  the  input  file,  an  error 
for  each  unresolved  label  is  produced  as  a  warning  to  the 
user. 

When  a  label  is  referenced  for  the  first  time  by  a 
GO  statement  the  symbol  table  is  initialized  with  the 
following:  1.)  unresolved  label  type  (0FFH),  2.)  the  address 
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of  the  GO  statement  (the  intermediate  code  would  be  BRN  00 
00  where  the  zeros  Indicate  where  the  address  of  the  label 
is  to  be  backstuffed.  See  section  1 1 1— D  for  specific 
explanation  of  pseudo-machine  instructions),  3.)  the 
remainder  of  the  label  entries  would  be  the  same  except  no 
entry  is  made  for  the  last  executable  instruction  associated 
with  the  label.  If  an  additional  reference  is  made  to  the 
label  by  a  subsequent  GO  statement  the  following  action 
would  occur;  1.)  the  current  address  (bytes  four  and  five) 
would  be  placed  in  the  branch  address  of  the  GO  statement, 
2.)  the  address  of  this  branch  statement  would  be  placed  in 
bytes  four  and  five  of  the  symbol  table  entry.  This 
procedure  facilitates  linking  together  all  unresolved 
references  to  labels  so  as  a  result  when  the  label  is 
resolved  the  correct  branch  address  can  easily  be  placed 
into  the  intermediate  code. 

Encountering  a  PERFORM  statement  before  a  label  is 
declared  causes  the  following  actions:  1.)  Bytes  four  and 
five  contain  the  address  of  the  next  byte  of  intermediate 
code  following  the  PER  intermediate  code  Instruction,  and 
2.)  bytes  eight  and  nine  contain  the  address  of  the  third 
byte  following  the  PER  instruction.  If  a  subsequent  PERFORM 
statement  is  encountered  before  the  label  is  resolved  the 
two  address  fields  in  the  symbol  table  would  be  copied  to 
the  associated  bytes  following  the  most  current  PERFORM 
statement  and  the  address  of  the  first  and  third  bytes 


following  the  PER  instruction  would  be  copied  into  the 
symbol  table.  It  should  be  pointed  out  that  any  number  of 
PERF0PM  and  GO  statements  can  be  specified  before  a  label  is 
resolved. 

7.  Files 

The  symbol  table  entries  for  files  are  the  most 
difficult  to  understand.  The  complexity  of  the  entries  is 
due  to  the  way  files  and  records  are  declared  in  a 
MICRO-COBOL  program.  The  symbol  table  entry  for  a  file 
consists  of  the  following:  1.)  byte  two  contains  the  type, 
2.)  byte  three  contains  the  length  of  the  file  name,  3.) 
bytes  four  and  five  contain  the  address  in  the  symbol  table 
of  the  first  01  level  record  associated  with  the  file,  4.) 
bytes  eight  and  nine  contain  the  beginning  address  of  the 
file  control  block  and  Input/output  buffer  for  the  file, 
(this  would  be  the  actual  address  in  the  data  section  of  the 
pseudo-machine  for  the  beginning  of  the  165  bytes  associated 
with  the  file),  5.)  if  the  file  has  a  key  entry  associated 
with  it  (access  via  RANDOM  or  RANDOM  RELATIVE)  bytes  ten  and 
eleven  contain  the  symbol  table  address  of  the  access  key 
variable,  and  6.)  the  rest  of  the  entry  contains  the  file 
name.  Figure  [II-6]  illustrates  a  file  entry  in  the  symbol 
table. 

8.  Records 
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This  entry  contains  seven  attributes  of  a  record. 
Three  are  the  same  as  all  other  entries  type,  name,  and 
length  of  name.  While  the  other  four  are:  1.)  bytes  four  and 
five  contain  the  initial  storage  address  for  the  record,  2.) 
bytes  six  and  seven  contain  the  number  of  bytes  of  storage 
for  the  record,  3.)  bytes  eight  and  nine  contain  the  symbol 
table  address  of  the  file  associated  with  the  record  (this 
facilitates  referencing  the  file  when  the  record  is 
written),  and  4.)  byte  ten  contains  the  level  entry  for  the 
record . 
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Fill  STMBOL  TABLE  ENTRY 
SAMPLE  SOURCE  PROGRAM  PILE  DECLARATION 


INPUT-OUTPUT  SECTION. 

PILE-CONTROL. 

SELECT  ROSTER-FIL 

ORGANIZATION  RELATIVE 
ACCESS  RANDOM  RELATIVE  NUM 
ASSIGN  CS81-FIL. 


BYTE  STMBOL  TABLE  VALUE 

0-1  j  colllson  link 

2  !  type  file 

i  (03) 

i 

3 

4-5 

length  of  file 
name  (05) 

symbol  table 
address  of  first 

01  level  record 
(09  2E) 

•  6-7 

8-9 

not  used 

first  address  of 
FCB  &  buffer 
(0E  26) 

10-11 

symbol  table 
address  of  key 
(33  27) 

12-13 

not  used 

14-18 

file  name 

(52  4F  53  54  45  52 
5F  46  49  4C ) 

FIGURE  I 1-7 


C.  COMPILER  MODULE  "PART  ONE 


1.  Purpose 

The  first  module  of  the  compiler  performs  several 
functions,  first,  it  establishes  the  interface  between  the 
compiler  and:  1.)  the  input  source  file  (of  type  ”CBL"),  2.) 
the  output  intermediate  code  file  (of  type  "CIN"),  3.)  the 
output  list  file  (of  type  "LST"),  and  4.)  the  READER  module 
which  reads  and  passes  control  to  PART  TVO  of  the  compiler. 
Second,  it  scans  and  parses  the  source  program  statements  up 
to  the  PROCEDURE  DIVISION.  Third,  it  generates  output 
consisting  of  the  symbol  table  entries  (saved  in  memory)  and 
data  initialization  intermediate  code.  A  listing  file  is 
also  created  which  will  contain  any  compilation  errors 
generated  and  a  listing  of  the  source  code  if  the 
appropriate  toggle  is  activated.  See  Appendix  A  for  a  list 
of  compiler  options. 

2.  Control  Actions 

By  executing  the  command  COBOL  <source  program> 
$<compller  toggles>  the  object  code  for  PART  ONE  of  the 
compiler  is  loaded  into  memory  starting  at  10GR  (if 
necessary  this  can  be  modified  for  different  machines)  by 
the  CP/M  operating  system.  Execution  of  PART  ONE  loads  the 
source  program  name  into  the  input  file  control  block 
located  at  SCH.  This  allows  the  source  program  name  to  be 


saved  until  actual  source  program  compilation  begins.  The 
compiler  toggles  are  loaded  Into  the  input  file  control 
block  located  at  6CB.  These  optional  toggles  are  used  later 
to  Initialize  certain  features  such  as  code,  nocode,  list, 
nolist,  etc.  See  Appendix  A  for  a  complete  list  of  options. 

Next,  the  control  program,  HEADER ,  is  moved  to  high 
memory  Just  below  the  BDOS  (see  reference  4  for  an 
explanation  of  BDOS  and  other  CP/P*  associated  names).  For 
example,  using  an  INTEL  Corporation  62K  MDS  microcomputer 
system  with  the  CP/M  operating  system,  the  READER  routine  is 
moved  to  high  memory  starting  at  0D000H  and  continuing 
through  0D0FFE.  This  is  done  for  two  reasons:  1.)  it  allows 
the  symbol  table  of  the  source  program  to  begin  at  the  next 
address  following  the  object  code  for  PART  ONE,  and  2.) 
places  READER  high  enough  in  memory  so  that  it  is  not 
destroyed  by  creation  of  the  symbol  table.  See  figures 
[II-71  and  [II-8]  for  illustrations  of  the  PART  ONE  memory 
organization  before  and  after  the  READER  routine  is  moved. 
The  purpose  of  the  READER  routine  will  be  explained  in  the 
next  section. 


MEMORY  ORGANIZATION  BEFORE  READER  ROUTINE  MOVED 


READER  Routine 
!  Before  Move 


}  Pert  1  of  Compiler 


i  — _ 


F000H 

Top  of  Memory 


D100H 


3700H 

3600H 


100H 

000E 


FIGURE  I I -7 
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MEMORY  ORGANIZATION  AFTER  READER  ROUTINE  MOVTD 


F800H 

Top  of  Merrory 

D1005 

D000R 

38008 

3600H 


100R 

000H 


i  BDOS 

i  READER  Routine 
I  After  Move 


!  I 

j 

i  Free  Area 
!  Reserved  for  Part  2 


I  Part  1  of  Compiler 


FIGURE  I I -8 
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Next,  the  interface  between  the  compiler  and  the  input 
file  <source  program>  and  the  output  file  intermediate  code 
file>  is  established.  The  input  file  control  block 
associated  with  the  source  file  is  initialized  and  the  input 
file  is  opened.  The  input  file  name  is  copied  to  the  output 
file  control  block  ( FCB)  and  if  there  is  an  intermediate 
code  file  already  residing  on  the  disk,  it  is  erased.  The 
output  FCB  is  initialized  and  a  file  directory  entry 
established  for  the  new  copy  of  the  intermediate  code  file. 
A  list  file  control  block  and  associated  buffer  are  created 
and  opened.  The  list  file  contains  any  error  messages 
generated  by  the  compiler  and  the  line  being  parsed  at  the 
time  the  error  was  discovered.  The  relative  line  number  is 
also  provided.  With  the  list  toggle  activated  the  list  file 
will  contain  the  complete  input  file  with  errors  and  line 
numbers. 

Prior  to  beginning  scanning  and  parsing  actions,  the 
first  128  byte  record  of  the  input  file  is  read  into  the 
input  buffer,  located  at  80H  (default  I/O  buffer  for  CP/M). 
The  scanner  is  primed  with  the  first  character  of  the  input 
program,  and  scanning  and  parsing  actions  continue  from  this 
point  in  PART  ONE  until  the  PROCEDURE  DIVISION  of  the  source 
program  is  encountered;  at  this  time  compilation  is 
suspended. 

3.  Symbol  Table  Entries 
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Entries  made  in  the  symbol  table  by  PART  ONE  will 
consist  of  all  identifiers  declared  in  the  DATA  DIVISION  of 
the  source  program.  By  refering  to  the  Symbol  Table  Section 
above,  an  explanation  may  be  obtained  regarding  the  various 
types  of  symbol  table  entries. 

4.  Intermediate  Code  Generation 

Pseudo-instructions  are  written  to  the  intermediate  code 
file  for  several  different  reasons  while  PART  ONE  is 
scanning  and  parsing  the  source  program.  The  first 
Intermediate  code  generated  occurs  when  the  INPUT-OUTPUT 
SECTION  of  a  source  program  is  nonempty.  Vi  thin  the  FILE 
CONTROL  PARAGRAPH  of  this  section.  instructions  are 
generated  to  initialize  the  PCB  for  the  file  name  associated 
with  the  SELECT  statement.  The  name  associated  with  the 
ASSIGN  statement  is  placed  in  the  PCB  and  is  used  in 
referencing  the  file  on  the  disk. 

Two  other  Instances  of  intermediate  code  generation 
occur  in  the  WORKING  STORAGE  SECTION  of  a  source  program. 
Anytime  a  record  or  elementary  identifier  entry  has  an 
edited  PICTURE  CLAUSE,  code  to  initialize  the  storage 
beginning  at  the  address  specified  in  the  formatted  mask 
attribute  of  the  symbol  table  entry  will  be  written  to  the 
intermediate  code  file.  When  a  record  or  elementary 
identifier  entry  has  an  associated  numeric  or  nornumerlc 
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TALUS  CLAUSE,  code  to  Initialize  the  storage  beginning  at 
the  address  specified  in  the  value  location  attribute  of  the 
symbol  table  entry  will  be  written  to  the  Intermediate  code 
file. 

The  final  pseudo-instruction  written  to  the  intermediate 
code  file  is  the  SCL  instruction.  This  occurs  when  the 
parser  parses  the  word  PROCEDURE  in  the  source  program; 
control  is  then  passed  to  PART  TWO  and  compilation 
continues. 

5.  Parser  Actions 

The  actions  corresponding  to  each  parse  step  are 
explained  below.  In  each  case,  the  grammar  rule  that  is 
being  applied  is  given,  and  an  explanation  of  what  program 
actions  take  place  for  that  step  has  been  included.  In 
describing  the  actions  taken  for  each  parse  step  there  has 
been  no  attempt  to  describe  how  the  symbol  table  is 
constructed,  what  pseudo-instructions  are  generated  or  how 
the  values  are  preserved  on  the  stack.  The  intent  of  this 
section  is  to  describe  what  information  needs  to  be  retained 
and  at  what  point  in  the  parse  it  can  be  determined.  Where 
no  action  is  required  for  a  given  statement,  or  where  the 
only  action  Is  to  save  the  contents  of  the  top  of  the  stack, 
no  explanation  is  given.  Questions  regarding  the  actual 
manipulation  of  information  should  be  resolved  by  consulting 
the  program  listings. 


1  <program>  <id-div>  <e-div>  <d-div>  PROCEDURE 

Reading  the  word  PROCEDURE  terminates  the  first 
part  of  the  compiler. 

2  <id-div>  IDENTIFICATION  DIVISION.  PROGRAM-ID. 

<comment>  .  <id-list> 

3  <id-list>  <auth>  <ins>  <date>  <sec> 

4  <auth>  AUTHOR  .  <comment>  . 

5  i  <empty> 

6  <ins>  =  INSTALLATION  .  <comment>  . 

7  |  <empty> 

8  <date>  s:  =  DATE-WRITTEN  .  <comment>  . 

9  i  <empty> 

10  <sec>  SECURITY  .  <comment>  . 

11  I  <empty> 

12  <comroent>  : s*  <input> 

13  i  <comment>  <input> 

14  <e-div>  ENVIRONMENT  DIVISION  .  CONFIGURATION 

SECTION.  <src-obj>  <i-o> 

15  !  <empty> 

16  <src-obJ>  SOURCE-COMPUTER  .  <comment>  <debug>  . 

OBJECT-COMPUTER  .  <comment>  . 

17  <debug>  DEBUGGING  MODE 

Set  a  scanner  toggle  so  that  debug  lines  will  be 
read. 

18  I  <empty> 

19  <i-o>  INPUT-OUTPUT  SECTION  .  FILE-CONTROL  . 
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<flle-control-list>  <ic> 

20  {  <empty> 

21  <file-control-list>  <file-control-entry> 

22  i  <file-control-list> 

<f ile-control-entry> 

23  <file-control-entry>  s:=  SELECT  <id>  Attribute-list^  . 

At  this  point  all  of  the  Information  about  the  file 
has  been  collected  and  the  type  of  the  file  can  be 
determined.  File  attributes  are  checked  for 

compatibility  and  entered  in  the  symbol  table. 

24  <attribute-list>  :s*  <one  attrib> 

25  S  <attribute-list>  <one  attrib> 

26  <one-attrib>  ORGANIZATION  <org-type> 

27  i  ACCESS  <acc-type>  <relative> 

28  !  ASSIGN  <lnput> 

A  file  control  block  is  built  for  the  file  using  the 
INT  operator. 

29  <org-type>  ; s*  SEQUENTIAL 

No  information  needs  to  be  stored  since  the  default 
file  organization  is  sequential. 

30  i  RELATIVE 

The  relative  attribute  is  saved  for  production  23. 

31  !  INDEXED 

The  Indexed  attribute  is  not  Implemented. 

27  <acc-type>  SEQUENTIAL 

This  is  the  default. 
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i  RANDOM 


The  random  access  mode  is  saved  for  production  19. 
29  <relative>  RELATIVE  <id> 

The  pointer  to  the  identifier  will  be  retained  by 
the  current  symbol  pointer,  so  this  production  only 
saves  a  flag  on  the  value  stack  indicating  that  the 
production  did  occur. 

35  {  <empty> 

36  <ic>  s:»  I-O-CONTROL  .  <same-list> 

37  |  <empty> 

38  <same-list>  <same-element> 

39  !  <same-list>  <same-element> 

40  <same-element>  :s»  SAME  <id-string>  . 

41  <ld-string>  <id> 

42  !  <id-string>  <id> 

43  <d-div>  DATA  DIVISION  .  <f ile-section>  <vork> 

<link> 

44  <flle-section>  FILE  SECTION  .  <file-list> 

A  flag  needs  to  be  set  to  indicate  completion  of 
the  file  section,  so  that  the  appropriate  routine 
will  be  called  when  parsing  level  entries  in  the 
WORKING  STORAGE  SECTION. 

45  !  <empty> 

The  flag,  indicated  in  production  44,  is  set. 

46  <flle-llst>  :*■  <file-element> 

47  |  <file-llst>  <file-element> 


48  <files>  : :»  FD  <id>  <flle-control>  . 

<record-descrlpti on> 

This  statement  Indicates  the  end  of  a  record 
description.  If  there  vas  an  Implied  redefinition 
of  the  record,  then  the  level  stack  (ID$STACE) 
must  be  reduced.  The  length  of  the  first  record 
description  and  its  address  can  now  be  loaded 
Into  the  symbol  table  for  the  file  name. 

49  <file-control>  :s=  <file-list> 

The  address  of  the  symbol  table  entry  for  the 
record  describing  the  file  name  is  entered  into  an 
attribute  of  the  file  name  symbol  table  entry, 
while  the  address  of  the  file  name's  symbol  table 
entry  is  entered  into  an  attribute  of  the  same 
record . 

50  {  <empty> 

Same  as  49  above. 

51  <flle-list>  <file-element> 

52  !  <file-list>  <f il e-element > 

53  <file-element>  BLOCS  <integer>  RECORDS 

54  I  RECORD  <rec-count> 

The  record  length  is  saved  for  comparison  with 
the  calculated  length  from  the  picture  clauses. 

55 
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I  LABEL  RECORDS  STANDARD 
!  LABEL  RECORDS  OMITTED 
I  VALUE  OF  <id-string> 


58  <rec-count>  <integer> 

59  i  <integer>  TO  <lateger> 

The  TO  option  Is  the  only  indication  that  the  file 
will  he  variable  length.  The  maximum  length  must  be 
saved. 

60  <work>  WORKING-STORAGE  SECTION  .  <record-descripti on> 

If  the  level  stack  (ID$STACK)  contains  a  record 
identifier  with  a  level  number  greater  than  one, 
then  the  stack  must  be  reduced.  The  reduction 
depends  on  whether  the  identifier  on  the  top  of 
the  stack  is  a  redefinition  of  the  item  beneath 
it  or  not.  The  primary  action  is  to  assign  the 
proper  amount  of  storage  to  the  last  record  in 
the  WORKING  STORAGE  SECTION. 

61  I  <empty> 

62  <llnk>  LINKAGE  SECTION  .  <record-desc ription> 

63  I  <empty> 

64  <record-descrlptlon>  <level-entry> 

65  |<record-description>  <level-entry> 

66  <level-entry>  <lnteger>  <data-ld>  <redefines> 

<data-type>  . 

The  symbol  table  address  for  the  level  entry 
identifier  is  loaded  into  the  level  stack 
( ID$STACK ) .  The  level  stack  keeps  track  of  the 
nesting  of  field  definitions  (elementary  items) 
in  a  record  in  the  FILE  and  WORKING  STORAGE 


SECTIONS.  At  this  point  there  may  he  no  infor¬ 
mation  about  the  length  of  the  item  being  defined 
and  its  attributes  may  depend  entirely  upon  its 
constituent  fields.  Vlthln  the  FILE  SECTION, 
multiple  record  descriptions  for  a  file  are 
assumed  to  be  redefinitions  of  the  first  record 
description.  In  the  WORKING  STORAGE  SECTION,  if 
there  is  a  VALUE  CLAUSE,  the  stach  level  to  vhich 
it  applies  is  saved  in  PENDING$LITERAL,  the  level 
entry  number  is  saved  in  TALUE$LEVEL  and  a  flag, 
VALUESFLAG,  is  set. 

67  <data-ld>  : s*  <ld> 

68  I  FILLER 

An  entry  is  built  in  the  symbol  table  to  record 
information  about  this  record  field.  It  cannot  be 
used  explicitly  in  a  program  because  it  has  no  name, 
but  its  attributes  will  need  to  be  stored  as  part  of 
the  total  record. 

69  <redeflnes>  REDEFINES  <ld> 

The  redefines  option  gives  new  attributes  to  a 
previously  defined  record  area.  The  symbol  table 
pointer  to  the  area  being  redefined  is  saved  in  an 
attribute  of  the  redefining  identifier's  symbol  table 
entry,  so  that  information  can  be  transferred  to  the 
area  by  either  identifier.  In  addition  to  the  inform¬ 
ation  saved  relative  to  the  redefinition,  it  is  nec- 


essary  to  check  to  see  if  the  curreat  Identifier's 
level  number  is  less  than  or  equal  to  the  level  number 
of  the  identifier  currently  on  the  top  of  the  level 
stack.  If  this  is  true,  then  all  Information  for  the 
item  on  top  of  the  stack  has  been  saved  and  the  stack 
can  be  reduced.  If  the  current  identifier  is  a  redef¬ 
inition  of  another  identifier,  the  stack  entry  for  the 
record  being  redefined  is  not  removed  until  the  first 
non-redefinition  of  a  current  Identifier  at  the  same 
level. 

70  I  <empty> 

As  in  production  64,  the  stack  (ID$STACK1  Is  checked 
to  determine  if  the  current  level  number  Indicates  a 
reduction  of  the  level  stack  is  necessary.  In  add¬ 
ition,  special  action  needs  to  be  taken  if  the  new 
level  is  01.  If  an  01  level  is  encountered  at  this 
production  prior  to  production  39  or  40  (the  end  of 
the  file  area),  it  is  an  implied  redefinition  of  the 
previous  01  level  record.  In  the  WORKING  STORAGE 
SECTION,  it  indicates  the  start  of  a  new  record. 

71  <data-type>  : :»  <prop-llst> 

72  )  <e»pty> 

73  <prop-llst>  i :■  <data-element> 

74  I  <prop-list>  <data-element> 

75  <data-element>  PIC  <input> 

The  <lnput>  at  this  point  is  the  character  string 

♦ 

46 


that  defines  the  record  field.  It  is  analyzed  and  tne 
necessary  extracted  information  is  stored  in  the 
symbol  table. 

76  i  USAGE  COMP 

The  field  is  defined  as  a  binary  field;  however, 

COMP  has  not  been  implemented,  therefore,  if 
there  is  an  associated  VALUE  CLAUSE,  the  value  is 
entered  into  the  associated  identifier's  value 
storage  location  in  display  format. 

77  |  USAGE  COMP-3 

The  field  is  defined  as  a  packed  Binary  Coded  Decimal 
field. 

78  !  USAGE  COMPUTATIONAL 

Optional  form  of  USAGE  COMP. 

79  I  USAGE  DISPLAT 

The  DISPLAY  format  is  the  default,  and  thus  no 
special  action  occurs. 

80  i  SIGN  LEADING  <separate> 

This  production  indicates  the  presence  of  a  sign  in 
a  numeric  field.  The  sign  will  be  in  a  leading 
position.  If  the  <separate>  indicator  is  true, 
then  the  length  will  be  one  longer  than  the  PICTURE 
CLAUSE,  and  the  type  will  be  changed  to  signed 
numeric  leading  and  separate. 

81  I  SIGN  TRAILING  <separate> 

The  same  information  required  by  production  73  must 
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be  recorded,  but  in  this  case  the  sign  is  trailing 
rather  than  leading. 

82  I  OCCURS  <integer>  INCIZED  <id> 

83  i  OCCURS  <integer> 

The  type  must  be  set  to  indicate  multiple 
occurrences  and  the  number  of  occurrences  saved 
for  computing  the  space  defined  by  this  field. 

84  S  STNC  <directi on> 

Syncronizatlon  with  a  natural  boundary  is  not 
required  by  this  machine. 

85  I  VALUE  <11 teral> 

The  field  being  defined  will  be  assigned  an  initial 
value  determined  by  the  value  of  the  literal  through 
the  use  of  an  INT  operator.  This  is  only  valid  in 
the  WORKING-STORAGE  SECTION.  Note  that  numeric  and 
signed  numeric  PICTURE  CLAUSES  will  have  a  numeric 

—  no  quotes  delimiting  —  VALUE  CLAUSE,  while 
alphanumeric  and  alpha  types  will  have  a  nonnumeric 

—  literal  delimited  with  quotes  —  VALUE  CLAUSE. 

86  <directlon>  LEFT 

8?  !  RIGHT 

88  I  <empty> 

89  <separate>  : :■  SEPARATE 

The  separate  sign  indicator  is  set. 

90  I  <empty> 

91  <literal>  <input> 
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The  input  string  is  checked  to  see  if  it  is  a  valid 
numeric  literal,  and  if  valid,  it  is  stored  to  be 
used  in  a  value  assignment. 


92 

93 


94 

95 

96 

97 

D. 


!  <lit> 

This  literal  is  a  quoted  string. 

I  ZERO 

As  the  case  of  all  literals,  the  fact  that  there 
is  a  pending  literal  needs  to  be  saved.  In  this 
case  and  the  three  following  cases,  an  indicator 
of  which  literal  constant  is  being  saved  is 
all  that  is  required.  The  literal  value  can  be 
reconstructed  later. 

!  SPACE 
I  QUOTE 

<integer>  <input> 

The  input  string  is  converted  to  an  Integer  value 
for  later  Internal  use. 

<id>  <lnput> 

The  input  string  is  the  name  of  an  identifier  and 
is  checked  aginst  the  symbol  table.  If  it  is  in  the 
symbol  table,  then  a  pointer  to  the  entry  is  saved. 
If  it  is  not  in  the  symbol  table,  then  it  is 
entered  and  the  address  of  the  entry  is  saved. 

INTERFACE  ACTIONS 
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When  compilation  is  suspended  in  PAST  ONE  of  the 
compiler  certain  key  variables  are  saved  for  use  in  PART 
TWO*  These  variables  are  declared  sequentially  in  PART  ONE 
and  are  therefore  located  in  contiguous  memory  in  the 
variable  area  of  PART  ONE.  These  variables  consist  of 
debugging  toggles  set  when  Invoking  the  compiler*  l.e. 
sequence  or  token  numbers,  a  pointer  to  the  next  available 
address  in  the  symbol  table,  a  pointer  to  the  next  character 
in  the  input  source  file,  the  output  and  list  file  control 
blocks,  the  output  and  list  buffers,  the  error  counter,  the 
next  address  in  the  intermediate  code  area,  the  next  address 
in  the  constants  area,  ana  the  base  address  of  the  symbol 
table.  These  key  variables,  consisting  of  353  bytes,  are 
copied  to  the  353  bytes  immediately  below  the  READER  routine 
to  insure  they  are  not  destroyed  when  PART  TWO  of  the 
compiler  is  brought  into  memory.  Since  the  memory  area 
required  for  PART  ONE  is  larger  than  that  required  by  PART 
TWO  the  symbol  table  does  not  need  to  be  relocated.  Since 
the  symbol  table  is  not  altered  when  PART  TWO  of  the 
compiler  is  brought  into  memory  only  the  base  address  of  the 
symbol  table  and  the  last  address  of  the  symbol  table  need 


be  saved  to 

Insure  that  access  to  the  symbol  table 

can 

be 

continued 

in 

PART  TWO. 

See  Figure  [11-10] 

for 

an 

Illustration 

of 

the  memory 

organisation  when  control 

is 

transfered  from  PART  ONE  to  READER.  The  READER  routine 
causes  PART  TWO  of  the  compiler  to  be  brought  into  memory 


starting  at  100H  and  then  transfers  control  to  PART  TWO  of 
the  Compiler. 


E .  COMPILER  MODULE  "PART  TWO*' 

1 .  Purpose 

The  second  part  of  the  compiler  scans  and  parses  the 
MICRO-COBOL  source  statements  starting  with  the  PROCEDURE 
DIVISION  and  generates  the  necessary  intermediate  code. 

2.  Control  Actions 

The  first  action  after  control  is  transfered  to  PART  TWO 
from  the  READER  routine  is  to  copy  the  353  bytes  of 
information  saved  from  PART  ONE  into  associated  variables  in 
PART  TWO.  After  these  variables  are  Initialized  all 
references  to  files,  symbol  table  entries,  ate.  can  be  made 
in  PART  TWO  and  compilation  can  continue.  See  Figure  [II-lll 
for  an  illustration  of  the  memory  organization  at  the  time 
PART  TWO  begins  compilation. 

3.  Symbol  Table  Entries 

Entries  made  in  the  symbol  table  by  PART  TWO  will  be 
those  for  paragraph  labels  encountered  within  the  PROCEDURE 
DIVISION  of  the  source  program. 

4.  Intermediate  Code  Generation 
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For  an  explanation  of  the  pseudo-instructions  that  are 
generated  by  PART  TWO  refer  to  the  compiler  program  listings 
and  the  parser  actions  below.  Also,  for  general  information 
on  pseudo-instructions  refer  to  section  III-D. 
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MIHORT  ORGANIZATION  WHEN  CONTROL  IS  TRANSFERER  TO  REARER 
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FIGURE  11-10 
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MEMORY  ORGANIZATION  AFTER  PART  TWO  IS  COPIED  INTO  MEMORY 
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FIGURE  11-11 


5.  Parser  Actions 


The  actions  corresponding  to  each  parse  step  In  PART  TWO 
are  explained  below.  In  each  case,  the  grammar  action  that 
Is  being  applied  is  given,  and  an  explanation  of  what 
program  actions  take  place  for  that  step  has  been  Included. 
In  describing  the  actions  taken  for  each  parse  step  there 
has  been  no  attempt  to  describe  how  the  symbol  table  entries 
are  made,  what  pseudo  Instructions  are  generated  or  how  the 
values  are  preserved  on  the  stack.  The  Intent  of  this 
section  is  to  describe  what  information  needs  to  be  retained 
and  at  what  point  in  the  parse  it  can  be  determined.  Where 
no  action  is  required  for  a  given  statement,  or  where  the 
only  action  Is  to  save  the  contents  of  the  top  of  the  stack, 
no  explanation  Is  given. 

1  <p-dlv>  PROCEDURE  DIVISION  <uslng>  . 

<proc-body>  EOT 

This  production  Indicates  termination  of  the 
compilation.  If  the  program  has  sections,  then 
it  will  be  necessary  to  terminate  the  last  section 
with  a  RET  0  instruction.  The  code  will  be  ended 
by  the  output  of  a  TER  operation. 

2  <using>  USING  <ld-string> 

If  the  reserved  word  CALL  is  on  the  procedure  stack  then 
the  PAR  operator  Is  produced  followed  by  the  addresses 
of  the  parameters  that  will  be  passed  from  the  calling 
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program.  If  the  reserved  words  PROCECEDURE  DIVISION  are 
on  the  procedure  stack  then  the  identifier  stack  contains 
the  formal  parameters  that  will  be  used  for  that  procedure. 
These  variables  are  given  sequential  address  locations 
starting  at  0DH  so  that  the  addresses  may  be  resolved  at  run 
time  by  getting  the  actual  parameter  address  off  the  call 
stack. 

PAR  <number  of  parameters>  <parameter  #1  address>  ... 

3  !  <empty> 

4  <id-string>  <id> 

The  identifier  stack  is  cleared  and  the  symbol 
table  address  of  the  identifier  is  loaded  into 
the  first  stack  location. 

5  I  <id-string>  <id> 

The  Identifier  stack  is  incremented  and  the  symbol 
table  pointer  stacked. 

6  <proc-body>  : :»  <paragraph> 

7  |  <proc-body>  <paragraph> 

8  <paragraph>  : <id>  . 

9  i  <ld>  .  <sentence-list> 

The  starting  and  ending  address  of  the  paragraph 
are  entered  into  the  symbol  table.  A  return  is 
emitted  as  the  last  instruction  in  the  paragraph 
(RET  0).  When  the  label  is  resolved,  it  may  be 
necessary  to  produce  a  BST  operation  to  resolve 
previous  references  to  the  label. 
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10 

j  <id>  SECTION  . 

The  starting  address  for  the  section 

is  saved. 

If 

it  is  not  the  first,  then  the  previous 

section  ending  address  is  loaded  and 

a  return 

(RET  0)  is  output.  As  in  production 

9,  a  BST 

may 

he  produced. 

11 

<sentence-list>  <sentence>  . 

12 

1  <sentence-list>  <sentence> 

• 

13 

<sentence>  : <lmperatlve> 

14 

S  <condi tlonal> 

15 

S  ENTER  <id>  <opt-id> 

This  construct  Is  not  Implemented.  An  ENTER  allows 
statements  from  another  language  to  Inserted  In  the 
source  code. 

16  <imperative>  ACCEPT  <suhld> 

ACC  <address>  <length> 

17  !  <arlthmetic> 

18  I  CALL  <call-lit>  <uslng> 

The  SBR  operator  Is  produced. 

SBR  Subroutine  name> 

19  !  CLOSE  <close-lst> 

CLS  <flle  control  block  address> 

20  !  <flle-act> 

21  !  DISPLAY  <dlsplay-lst> 

The  display  operator  Is  produced  for  the  first 
literal  or  identifier. 
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22 


23 

24 

25 


26 


27 

28 


m 


DIS  <address>  <length>  <flag> 

j  DISPLAY  <display-lst>  WITH  NO 
ADVANCING 


The  DISPLAY  WITH  NO  ADVANCING  option  Is  not  Implemented . 
S  EXIT  <program-id> 

RET  0 


I  GO  <id> 


BRN  <address> 

i  GO  <id-string>  DEPENDING  <id> 

GDP  Is  output,  followed  by  a  number  of  parameters: 

<the  number  of  entries  in  the  Identifier  stark> 

<the  length  of  the  depending  identified  <the 
address  of  the  depending  identified  <the  address 
of  each  Identifier  In  the  staclr>. 

!  MOVE  <llt/td>  TO  <subld> 

The  types  of  the  two  fields  determine  the  move  that 
is  generated.  Numeric  moves  go  through  register  two 
using  a  load  and  a  store.  Non-numeric  moves  depend 
upon  the  resultant  field  and  may  be  either  MOV,  MED  or 
MNE.  Since  all  of  these  Instructions  have  long 
parameter  lists,  they  have  not  been  listed  in 
detail. 

I  OPEN  <act-lst> 

I  PERFORM  <id>  <thru>  <finish> 

The  PER  operation  is  generated  followed  by  the 
<branch  address>  <the  address  of  the  return 
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statement  to  be  set>  and  <the  next  instruction 
address>. 

29  !  STOP  <terminate> 

If  there  is  a  terminate  message,  then  STE  is 
produced  followed  by  <message  address>  <message 
length>.  Otherwise  STP  is  emitted. 

30  <close-lst>  <id> 

31  i  <close-lst>  <id> 

Multiple  close  option  is  not  implemented. 

32  <display-lst>  <lit/id> 

33  !  <displajr-lst>  <lit/id> 

Multiple  display  option  is  not  implemented. 

34  <act-lst>  <type-action>  <open-lst> 

This  produces  either  OPJi,  0P1,  or  0P2  depending 
upon  the  <type-actlon>.  Each  of  these  is  followed 
by  file  control  bloc*  address. 

35  I  <act-lst>  <type-actlon>  <open-lst> 

36  <open-lst>  : s*  <id> 

37  {  <open-lst>  <id> 

Multiple  open  option  Is  not  Implemented. 

38  <flnish>  : !■  <l/id>  TIMES 

This  produces  the  code  to  perform  a  paragraph  <l/id>  TIMES. 

39  i  <stopconditlon> 

40  I  <varying>  <lteration>  <stopcendition> 

41  I  <empty> 

42  <stopcondition>  UNTIL  <condition> 


43  <varying>  VARYING  <subid> 

44  <iteration>  <from>  <by> 

45  <from>  FROM  <l/id> 

The  counter  is  initialized  to  <l/id>. 

46  <by>  BT  <l/ld> 

The  counter  is  incremented  BT  <l/ld>. 

47  <condltional>  <arithmetic>  <size-error>  <imperative> 

A  BST  operator  is  output  to  complete  the  branch  around 
the  imperative  from  production  117. 

48  I  <file-act>  <invalid>  Omperatl ve> 

A  BST  operator  is  output  to  complete  the  branch  from 
production  116. 

49  !  <read-id>  <speclal>  <imperative> 

A  BST  is  produced  to  complete  the  branch  around  the 
<imperatlve>. 

50  !  <if-nonterminal>  <condltion> 

<if-lst>  <else>  <if-lst>  END-IF 
NEG  will  be  emitted  unless  <condltlon>  is  a 
"NOT  <cond-type>",  in  which  case  the  two  negatives 
will  cancel  each  other.  Two  BST  operators  are  required. 
The  first  fills  in  the  branch  to  the  ELSE  action.  The 
second  completes  the  branch  around  the  <if-l$t> 
which  follows  ELSE. 

51  !  <if-nocterminal>  <conditioc> 

<if-lst>  END-IF 

52  <lf-lst>  <stmt-lst> 
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53  S  NEXT  SENTENCE 

A  branch  operator  is  produced  to  branch  to  the  end  of 
the  current  sentence. 

54  <else>  ELSE 

55  <Arithmetlc>  ADD  <add-lst>  TO  <subid>  <round> 

The  existence  of  multiple  load  and  store  instructions 
make  it  difficult  to  indicate  exactly  what  code  will 
be  generated  for  any  of  the  arithmetic  instructions. 
The  type  of  load  and  store  will  depend  on  the  nature 
of  the  number  involved,  and  in  each  case  the  standard 
parameters  will  be  produced.  This  parse  step  will  in¬ 
volve  the  following  actions:  first,  a  load  will  be 
emitted  for  the  first  number  into  register  zero.  If 
there  is  a  second  number,  then  a  load  into  register 
one  will  be  produced  for  it,  followed  by  an  ADD  and  a 
STI.  Next  a  load  into  register  one  will  be  generated 
for  the  result  number.  Then  an  ADD  Instruction  will 
be  emitted.  Finally,  if  the  round  Indicator  is  set,  a 
END  operator  will  be  produced  prior  to  the  store. 

56  !  ADD  <add-lst>  GIVING  <subid>  <round> 

The  ADD  GIVING  option  is  not  implemented. 

57  I  DIVIDE  <l/ld>  INTO  <l/id>  <round> 

The  first  number  is  loaded  into  register  zero.  The 
second  operand  is  loaded  into  register  one.  A  DIV 
operator  is  generated,  followed  by  a  RND  operator 
prior  to  the  store,  if  required. 
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58  S  DIVIDE  <l/id>  BY  <l/id>  GIVING 

<subld>  vrouad> 

The  DIVIDE  GIVING  option  Is  not  implemented. 

59  !  DIVIDE  <l/ld>  INTO  <l/id>  GIVING 

<subid>  <round> 

60  !  MULTIPLY  <l/id>  BY  <subid>  <round> 

The  multiply  Is  the  same  as  the  divide  except  that  a 
MUL  operator  Is  generated. 

61  I  MULTIPLY  <l/id>  BY  <l/ld>  GIVING 

<subid>  <round> 

62  I  SUBTRACT  <sub-lst>  FROM  <subld> 

<round> 

Subtaction  generates  the  same  code  as  the  ADD  except 
that  a  SUB  Is  produced  in  place  of  the  ADD. 

63  {  SUBTRACT  <sub-lst>  GIVING  <subld> 

<round> 

The  SUBTRACT  GIVING  option  is  not  implemented. 

64  !  COMPUTE  <subid>  *  <arith-exp> 

The  COMPUTE  verb  is  not  implemented. 

65  <add-lst>  <l/ld> 

66  j  <add-lst>  <l/id> 

Multiple  ADD  option  is  not  implemented. 

6?  <sub-lst>  <l/id> 

68  I  <sub-lst>  <l/ld> 

Multiple  SUBTRACT  option  is  not  implemented. 

69  <arlth-exp>  <term> 
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Productions  69  through  80  are  required  for  the  COMPUTE 
verb  and  are  not  implemented. 


70 

S  <arith-exp>  + 

<term> 

71 

!  <arlth-exp>  - 

<term> 

72 

S  ♦  <term> 

73 

i  -  <term> 

74 

<term>  <primary> 

75 

!  <term>  *  <primary> 

76 

!  <term>  /  <prlmary> 

77 

<primary>  <prim-elem> 

78  !  <primary>  **  <prim-elem> 

79  <prim-elem>  <l/id> 

80  }  {  <arith-exp>  ) 

81  <file-act>  DELETE  <ld> 

Either  a  DLS  or  a  DLH  will  he  produced  along  with  the 
required  parameters. 

82  !  REWIITE  <id> 

Either  a  R¥S  or  a  R¥R  is  emitted,  followed  by  parame¬ 
ters  . 

83  I  ¥RITE  <id>  <special-act> 

There  are  four  possible  write  instructions:  ¥TF ,  ¥VL, 
¥RS ,  and  ¥RR. 

84  <condltlon>  <hterm> 

The  logical  OR  and  AMD  operators  are  not  implemented. 

85  I  <condltlon>  OR  <bterm> 

86  <hterm>  : :■  <hprlm> 
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87  i  <bterm>  AND  <bprim> 

88  <bprim>  s :■  <lit/id> 

89  {  <lit>  <not>  <cond-type> 

One  of  the  compare  instructions  is  produced.  They  are 
CAL,  CNS,  CNU,  RGT,  RLT,  RIO,  SGT,  SLT,  and  SEO. 

Two  load  instructions  and  a  SUE  will  also  be  generated 
if  one  of  the  register  comparisons  is  required. 

90  !  (  <bterm>  ) 

91  <cond-type>  NUMERIC 

92  |  ALPHABETIC 

93  i  <compare>  <lit/id> 

94  <not>  s :=  NOT 

NEG  is  emitted  unless  the  NOT  is  part  of  an  IF 
statement  in  which  case  the  NEG  in  the  IF 
statement  is  cancelled. 

95  J  <empty> 

96  <compare>  GREATER 

97  !  LESS 

98  i  EQUAL 

99  I  > 

Productions  99-101  are  not  Implemented. 

100  S  < 

101  I  - 

102  <ROUND>  :s»  ROUNDED 

103  I  <empty> 

104  <terminate>  <literal> 
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105  !  HUN 

106  <special>  <invalld> 

10?  {  END 

An  ZOR  operator  is  emitted  followed  by  a  zero.  The 
zero  acts  as  a  filler  in  the  code  and  will  be  back- 
stuffed  with  a  branch  address.  In  this  production 
and  several  of  the  following,  there  is  a  forward 
branch  on  a  false  condition  past  an  imperative  action. 
?or  an  example  of  the  resolution,  examine  production  48. 

108  <opt-id>  :  :«=  <subld> 

109  i  <empty> 

110  <stmt-lst>  s  :=  <imperative> 

111  i  <stmt-lst>  <lmperative> 

112  S  <conditional> 

113  I  <stmt-lst>  <conditional> 

114  <thru>  : s=  THRU  <id> 

115  !  <empty> 

116  <1 nvalld>  INVALID 

INV  0 

117  <size-error>  SIZE  ERROR 

SER  0 

118  <special-act>  <when>  ADVANCING  <how-many> 

119  I  <empty> 

120  <when>  : s*  BEFORE 

121  !  AFTER 

122  <how-many>: s»  <integer> 
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123 

{  PAGE 

124 

<type-action>  =  INPUT 

125 

!  OUTPUT 

126 

1  1-0 

127 

<subld>  :: 

■  <subscript> 

128 

I  <id> 

129 

<integer> 

: :*  <lnput> 

The  value  of  Che  input  string  is  saved  as  an  internal 
number . 

130  <id>  <input> 

The  identifier  is  checked  against  the  symbol  table,  if 
it  is  not  present,  it  is  entered  as  an  unresolved 
label. 

131  <l/id>  : <input> 

The  input  value  may  be  a  numeric  literal.  If  so,  it 
is  placed  in  the  constant  area  with  an  INT  operator. 
If  it  is  not  a  numeric  literal,  then  it  must  be  an 
identifier,  and  it  is  located  in  the  symbol  table. 

132  i  <subscript> 

133  !  ZERO 

134  <subscript>  <id>  (  <subscript-lst>  ) 

A  SCR  operator  is  produced  with  the  base  address  of  a 
variable  defined  with  an  OCCURS  clause.  Multiple 
subscripting  has  not  been  implemented. 

135  <subscript-lst>  <lnput> 

I  <subscript-lst>  ,  <input> 
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137 

<call-lit> 

: :=  <lit> 

The  name 

of  the  module  to  be  called  is  saved  for  use 

in  production  18. 

138 

<nn-lit>  : 

:=  <lit> 

The  literal  string  is  placed  into  the  constant  area 

using  an 

INT  operator. 

139 

!  SPACE 

140 

i  QUOTE 

141 

<11 teral> 

: :=  <nn-lit> 

142 

S  <input> 

The  Input  value  must  be  a  numeric  literal  to  be  valid 
and  is  loaded  into  the  constant  area  using  an  INT 
operator. 
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J  ZERO 

144 

<11 t/id> 

<l/id> 

145 

! 

<nn-lit> 

146 

<program-id> 

::=  <id> 

147 

i  <empty> 

148 

<read-id>  :: 

«  READ  <id> 

There  are  four  read  operations:  RDF,  RVL,  RRS,  and 
HER. 

149  <if-nonterminal>: :*IF 
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III.  NPS  MICRO-COBOL  INTERPRETER 


A.  GENERAL  DESCRIPTION 

The  following  sections  describe  the  NPS  MICRO-COBOL 
pseudo-machine  in  terms  of  the  implementation,  memory 
organization,  interface  actions  and  interpreter 
instructions.  The  pseudo-machine,  which  is  constructed  in 
the  transient  program  area  of  CP/M,  is  the  target  machine 
for  the  compiler  and  is  implemented  through  a  programmed 
interpreter.  The  interpreter  decodes  each  operation  and 
either  calls  subroutines  to  perform  the  required  actions  or 
acts  directly  on  the  run  time  environment  to  control  the 
actions  of  the  interpreter.  All  communications  between 
instructions  is  done  through  common  areas  in  the  program 
where  information  can  be  stored  for  later  use.  See  figure 
CIII-1]  for  an  illustration  of  the  pseudo-machine 
organization. 

The  machine  contains  a  program  counter  and  multiple 
parameter  operations  which  contain  all  the  information 
required  to  perform  one  complete  action  required  by  the 
language.  Three  eighteen  digit,  double  length  registers  are 
used  for  arithmetic  operations,  along  with  a  subscript  stack 
used  to  compute  subscript  locations,  a  parameter  stack  to 
resolve  the  address  of  actual  parameters  and  a  set  of  flags 
which  are  used  to  pass  branching  Information  from  one 
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instruction  to  another. 

Addresses  in  the  pseudo-machine  are  represented  by  16 
bit  values.  Any  memory  address  greater  than  20  hexidecimal 
is  valid.  Addresses  less  than  20  hexidecimal  will  be 
interpreted  as  having  special  significance.  For  example 
addresses  one  through  eight  are  reserved  for  subscript  stack 
references.  All  other  addresses,  in  the  machine  are  absolute 
addresses 

The  registers  allow  manipulation  of  signed  numbers  up  to 
eighteen  digits  in  length.  Included  in  their  representation 
is  a  sign  indicator  and  the  position  of  the  assumed  decimal 
point  for  the  currently  loaded  number.  Numbers  are 
represented  in  standard  COBOL  "Display"  or  "Binary  Coded 
Decimal"  (COMP-3  or  BCD)  format.  These  numbers  may  have 
separate  signs  indicated  by  "+"  and  or  may  have  a  "zone" 
indicator,  denoting  a  negative  sign,  in  the  most  significant 
byte  of  a  number's  storage  location.  Before  operations  occur 
on  any  number,  it  is  converted  to  a  packed  decimal  format 
and  entered  into  one  of  the  pseudo-machine  registers. 

B.  MEMOS!  ORGANIZATION 

The  memory  of  the  pseudo-machine  is  divided  into  three 
major  areas:  1.)  the  data  area  is  established  by  the  DATA 
DIVISION  statements  of  the  source  program,  2.)  the  constants 
area  which  is  established  by  both  the  DATA  and  PROCEDURE 
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DIVISIONS  of  the  source  program,  and  3.)  the  code  area  which 
is  established  by  the  PROCEDURE  DIVISION. 

The  data  area  is  the  lowest  area  in  the  pseudo-machine. 
This  area  contains  the  storage  for  identifiers  declared  in 
the  DATA  DIVISION.  Additionally,  the  data  area  contains  the 
File  Control  Block  (FCB)  and  the  buffer  space  (128  bytes) 
for  all  files  declared  in  the  source  program. 

Immediately  following  the  data  area  is  the  code  area. 
This  contiguous  area  of  storage  contains  all  executable  code 
generated.  The  constants  area  is  located  in  high  memory  of 
the  pseudo-machine.  This  area  contains  all  edit  field  masks 
as  well  as  all  numeric  and  non-numeric  literals.  Figure 
[III-l]  illustrates  the  memory  organization  of  tne 
pseudo-machine. 


70 


PS KUDO-MACHINE  ORGANIZATION 
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FIGURE  III-l 
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C.  INTERPRETER  INTERPACE 


The  Interpreter  consists  of  two  interface  routines  and 
the  main  interpreter  program.  To  execute  the  interpreter  the 
command  EXEC  <filename>,  (where  file  type  is  CIN),  is  typed 
at  the  terminal.  This  action  causes  the  two  Interface 
routines,  BUILD  and  INTRDR,  to  be  brought  into  memory.  See 
figure  [III-2]  which  illustrates  the  memory  organization 
immediately  after  BUILD  and  INTRDR  have  been  copied  Into 
memory. 

The  BUILD  routine  reads  in  the  intermediate  code, 
initializes  all  memory  locations  requiring  initialization, 
and  resolves  all  unresolved  address  references.  In  addition 
the  BUILD  routine  loads  subroutines  into  memory.  If  a  SBR 
Instruction  is  encountered  during  execution  of  BUILD,  the 
SUBSPLAC  is  set  as  an  indicator  that  subroutines  will  have 
to  be  loaded.  The  name  of  the  subroutine  is  saved  and  when 
the  TER  instruction  is  encountered  a  check  of  the  SUE$FLAG 
is  made  and  if  set  each  subroutine  is  loaded  into  memeory.  A 
table  similar  to  the  compiler's  symbol  table  is  used  to 
maintain  the  names,  location,  and  status  (loaded  or 
unloaded)  of  each  subroutine.  Until  a  subprogram  is  loaded 
the  actual  branch  address  is  not  known.  The  same  mechanism, 
used  for  resolving  forward  branches  to  paragraphs  is  used  to 
backstuff  all  previous  references  to  the  called  procedure. 
Once  loaded  the  address  is  known  so  no  futher  action  is 
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required.  See  figure  [II 1—5]  for  an  illustration  of  a 
subroutine  table  entry. 

The  INTRDR  routine  reads  the  interpreter  program  into 
memory  and  transfers  control  to  it. 

The  intermediate  code  instructions  fall  into  two 
categories:  1.)  instructions  used  by  BUILD  to  establish  the 
run  time  environment  and,  2.)  instructions  to  be  executed  by 
the  interpreter.  The  following  four  instructions  are 
generated  in  the  compiler  for  use  by  the  BUILD  routine*  SCD, 
INT,  BST ,  and  TEH. 

The  SCD  (start  code)  instruction  is  the  last  instruction 
generated  by  PART  ONE  and  indicates  where  the  first 
executable  instruction  for  the  intermediate  code  is  to  be 
loaded.  This  corresponds  to  the  address  Immediately 
following  the  data  area  in  the  pseudo-machine.  See  Figure 
[III-l]  which  illustrates  the  relative  location  of  the 
address  that  is  associated  with  the  SCD  instruction.  Figure 
[I I 1-4]  illustrates  the  memory  organization  of  the 
pseudo-machine  when  subroutines  are  used. 
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MEMORY  ORGANIZATION  AFTER  BUILD  ANE  I NTS DR 
HAVE  BEEN  LOADED  INTO  MEMORY 
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The  INT  (Initialize)  instruction  causes  the  BUILD 
routine  to  initialize  the  data  area  with  the  values 
associated  with  those  identifiers  in  the  DATA  DIVISION  of 
the  source  program  that  had  VALUE  CLAUSES.  In  addition,  the 
INT  instruction  causes  the  BUILD  routine  to  initialize  the 
constants  area  with  all  the  edit  masks  for  those  identifiers 
of  the  numeric  and  alphanumeric  edit  type,  and  all  literals 
encountered  in  the  PPOCEDURE  DIVISION  of  the  source  program. 

The  BST  (backstuff)  instruction  resolves  all  unresolved 
references,  i.e.  branches  to  labels  defined  after  the 
respective  PERTOBM  or  GO  statement  was  encountered  in  the 
source  program. 

The  TER  (terminate)  instruction  is  the  last  instruction 
generated  by  PART  TWO  of  the  compiler  and  indicates  the  end 
of  the  intermediate  code  file.  Upon  encountering  a  TER 
instruction  in  the  intermediate  code  the  BUILD  routine 
Inserts  a  STP  instruction  in  its  place.  The  STP  instruction 
will  cause  the  interpreter  to  terminate  interpretation  of 
the  program  when  encountered. 

All  other  code  generated  by  the  compiler  is  copied  into 
the  code  area  of  the  pseudo-machine  by  the  BUILD  routine. 
See  Figure  [1 1 1—31  For  an  illustration  of  the  memory 
organization  at  this  point  in  the  initialization  routine. 
The  final  action  taken  by  the  BUILD  routine  is  to  move  the 
INTRDR  routine  into  the  input  buffer  at  60R  and  transfer 
control  to  it.  This  frees  the  area  from  100H  to  the  base  of 


the  data  area  for  the  interpreter. 

The  INTRDR  routine  reads  the  interpreter  program  into 
memory  starting  at  100H  and  transfers  control  to  it.  From 
this  point  on  the  interpreter  program  executes  the 
intermediate  code  that  was  loaded  into  the  pseudo-machine. 
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MEMORY  ORGANIZATION  AFTER  INTERMEDIATE  CODE  IS 
LOADED  INTO  MEMORY  AND  BEFORE  THE  INTERPRETER 

IS  LOADED 
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MEMORY  ORGANIZATION  AFTER  THE  INTERMEDIATE  CODE, 
SUBROUTINES  AND  THE  INTERPRETER  ARE  LOADED. 
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D.  PSEUDO-MACHINE  INSTRUCTIONS 

This  section  briefly  covers  the  pseudo-machine 
instructions  used  in  the  interpreter,  their  format,  and  the 
actions  which  they  accomplish. 

1 .  Format 

All  of  the  interpreter  instructions  consist  of  an 
instruction  number  followed  by  a  list  of  parameters.  The 
following  sections  describe  the  instructions,  list  the  re¬ 
quired  parameters,  and  describe  the  actions  taken  by  the 
machine  in  executing  each  instruction.  In  each  case,  parame¬ 
ters  are  denoted  informally  by  the  parameter  name  enclosed 
in  brackets.  The  BRN  branching  instruction,  for  example, 
uses  the  single  parameter  <branch  address>  which  is  the  tar¬ 
get  of  the  unconditional  branch. 

As  each  instruction  number  is  fetched  from  memory, 
the  program  counter  is  incremented  by  one.  The  program 
counter  is  then  either  incremented  to  the  next  instruction 
number,  or  a  branch  is  taken. 

The  three  eighteen  digit  registers  which  are  used  by 
the  Instructions  covered  in  the  following  sections  are  re¬ 
ferred  to  as  registers  zero,  one,  and  two. 

2.  Arithmetic  Operations 

There  are  five  arithmetic  instructions  which  act 
upon  the  three  registers.  In  all  cases,  the  result  is 


Placed  in  register  two.  Operations  are  allowed  to  destroy 
the  input  values  during  the  process  of  creating  a  result, 
therefore,  a  number  loaded  into  a  register  is  not  available 
for  a  subsequent  operation. 

ADD:  (addition).  Sum  the  contents  of  register  zero 
and  register  one. 

Parameters:  no  parameters  are  reo.uired. 

SUB:  (subtract).  Subtract  register  zero  from  register 

one. 

Parameters:  no  parameters  are  required. 

MUL:  (multiply).  Multiply  register  zero  by  register 

one. 

Parameters:  no  parameters  are  required. 

DIV:  (divide).  Divide  register  one  by  the  value  in 
register  zero.  The  remainder  is  not  retained. 

Parameters:  no  parameters  are  required 

RND:(round).  Hound  register  two  to  the  last  signifi¬ 
cant  decimal  place. 

Parameters:  no  parameters  are  required. 

3.  Branching 

The  machine  contains  the  following  flags  which  are 
used  by  the  conditional  instructions  in  this  section. 

BRANCH  flag  —  indicates  if  a  branch  is  to  be  taken; 
END  OT  RECORD  flag  —  indicates  that  an  end  of 
input  condition  has  been  reached  when  an  attempt  was  made 
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to  read  input! 


OVERFLOW  flag  —  indicates  the  loss  of  information 
from  a  register  due  to  a  number  exceeding  the  available 
size; 

INVALID  flag  —  indicates  an  invalid  action  in 
writing  to  a  direct  access  storage  device. 

All  of  the  branch  instructions  are  executed  by 
changing  the  value  of  the  program  counter.  Some  are  uncon- 
ditional  branches  and  some  test  for  condition  flags  which 
are  set  by  other  Instructions.  A  conditional  branch  is  exe¬ 
cuted  by  testing  the  branch  flag  which  is  initialized  to 
false.  A  true  value  causes  a  branch  by  changing  the  pro¬ 
gram  counter  to  the  value  of  the  branch  address.  The  branch 
flag  is  then  reset  to  false.  A  false  value  causes  the  pro¬ 
gram  counter  to  be  incremented  to  the  next  sequential  in¬ 
struction. 

BRN:  (branch  to  an  address).  Load  the  program 

counter  with  the  <branch  address>. 

Parameters:  <branch  address> 

The  next  three  instructions  share  a  common  format. 
The  memory  field  addressed  by  the  <memory  address>  is 
checked  for  the  <address  length>,  and  if  all  the  characters 
match  the  test  condition,  the  .  .anch  flag  is  complimented 
Parameters:  <rremory  address>  <address  length>  <branch  ad- 
dress> 

CAL:  (compare  alphabetic).  Compare  a  memory  field 
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for  Alphabetic  characters. 

CNS:  (compare  numeric  signed).  Compare  a  field  for 

numeric  characters  allowing  for  a  sign  character. 

CNUs  (compare  numeric  unsigned).  Compare  a  field  for 
numeric  characters  only. 

DEC:  (decrement  a  counter  and  branch  if  zero). 
Decrement  the  value  of  the  <address  counter>  by  one*  if  the 
result  is  zero  before  or  after  the  decrement,  the  program 
counter  is  set  to  the  <branch  address>.  If  the  result  is 
not  zero,  the  program  counter  is  incremented  by  four. 
Parameters:  <address  counter>  <branch  address> 

EOR :  (branch  on  END  OF  RECORD  flag).  If  the  END 

OF  RECORD  flag  is  true,  it  is  set  to  false  and  the  program 
counter  is  set  to  the  <branch  address>.  If  false,  the  pro¬ 
gram  counter  is  incremented  by  two. 

Parameters:  <branch  address> 

GDP:  (go  to  -  depending  on).  The  memory  location  ad¬ 
dressed  by  the  <number  address>  is  read  for  the  number  of 
bytes  indicated  by  the  <memory  length>.  This  number  indi¬ 
cates  which  of  the  <branch  addresses>  is  to  be  used.  The 
first  parameter  is  a  bound  on  the  number  of  branch  ad¬ 
dresses.  If  the  number  is  within  the  range,  the  program 
counter  is  set  to  the  indicated  address.  An  out-of-bounds 
value  causes  the  program  counter  to  be  advanced  to  the  next 
sequential  instruction. 

Parameters:  <bound  number  -  byte>  <memory  length>  <memory 
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address>  <branch  addr-l>  <branch  addr-2>  ...  <branch  addr-n> 
INV:  (branch  if  INVALID  flag  true).  If 
the  Invalid-file-action  flag  is  true,  then  it  is  set  to 
false,  and  the  program  counter  is  set  to  the  branch  ad¬ 
dress.  If  it  is  false,  the  program  counter  is  incremented 
by  two. 

Parameters:  <branch  address> 

PER:  (perform).  The  code  address  addressed  by  the 
<change  address>  is  loaded  with  the  value  of  the  <return  ad- 
dress>.  The  program  counter  is  then  set  to  the  <branch  ad- 
dress>. 

Parameters:  <branch  address>  <change  address>  <return  ad- 
dress> 

RET:  (return).  If  the  value  of  the  <branch  address> 
is  not  zero,  then  the  program  counter  is  set  to  its  value, 
and  the  <branch  address>  is  set  to  zero.  If  the  Cbranch  ad- 
dress>  Is  zero,  the  program  counter  is  incremented  by  two. 
Parameters:  <branch  address> 

REQ:  (register  equal).  This  instruction  checks  for  a 
zero  value  in  register  two.  If  it  is  zero,  the  branch  flag 
is  complemented.  A  conditional  branch  is  taken. 

Parameters:  <branch  address> 

RGT:  (register  greater  than).  Register  two  is 


checked  for  a  negative  sign.  If  present,  the  branch  flag  is 
complemented.  A  conditional  branch  is  taken. 

Parameters:  <branch  address> 


HLT:  (register  less  than).  Register  two  is  checked 
for  a  positive  sign*  and  if  present,  the  branch  flag  is  com* 
plemented.  A  conditional  branch  is  taken. 

Parameters:  <branch  address> 

SER:  (branch  on  size  error).  If  the  overflow  flag  is 
true,  then  the  program  counter  is  set  to  the  branch  address, 
and  the  overflow  flag  is  set  to  false.  If  it  is  false,  then 
the  program  counter  is  incremented  by  two. 

Parameters:  <branch  address> 

The  next  three  instructions  are  of  similar  form  in 
that  they  compare  two  strings  and  set  the  branch  flag  if 
the  condition  is  true. 

Parameters:  <string  addr-l>  <string  addr-2>  Clength  -  ad- 
dress>  <branch  address> 

S2Q:  (strings  equal).  The  condition  is  true  if  the 
strings  are  equal. 

SGT:  (string  greater  than).  The  condition  is  true  if 
string  one  is  greater  than  string  two. 

SIT:  (string  less  than).  The  condition  is  true  if 
string  one  is  less  than  string  two. 

4,  Moves 

The  machine  supports  a  variety  of  move  operations 
for  various  formats  and  types  of  data.  It  does  not  support 
direct  moves  of  numeric  data  from  one  memory  field  to  anoth¬ 
er  Instead,  all  numeric  moves  go  through  the  registers. 


The  next  seven  instructions  perform  the  same 
function.  They  load  a  register  with  a  numeric  value  and 
differ  only  in  the  type  of  number  that  they  expect  to  see  in 
memory  at  the  <number  address>.  All  seven  instructions 
cause  the  program  counter  to  be  incremented  by  five.  Their 
common  format  is  given  below. 

Parameters!  <number  address>  <byte  length>  <byte  decimal 
count>  <byte  register  to  load> 

LCD:  (load  literal).  Register  two  is  loaded  with  a 
constant  value.  The  decimal  point  indicator  is  not  set  in 
this  instruction.  The  literal  will  have  an  actual  decimal 
point  in  the  string  if  required. 

LD1:  (load  numeric).  Load  a  numeric  field. 

LD2:  (load  postfix  numeric).  Load  a  numeric  field 
with  an  Internal  trailing  sign. 

LD3;  (load  prefix  numeric).  Load  a  numeric  field 
with  an  Internal  leading  sign. 

LD4:  (load  separated  postfix  numeric).  Load  a  numer¬ 
ic  field  with  a  separate  leading  sign. 

LL5:  (load  separated  prefix  numeric).  Load  a  numeric 
field  with  a  separate  trailing  sign. 

LD6:  (load  packed  numeric).  Load  a  packed  numeric 

field. 

(ISC:  (move  into  alphanumeric  edited  field).  The 
edit  mask  is  loaded  into  the  <to  adiress>  to  set  up  the 
move,  and  then  the  <from  address>  information  is  loaded.  The 


program  counter  is  incremented  by  ten. 

Parameters:  <to  address>  <from  address>  <length  of  trove 
address>  <edit  mask  address>  <edit  mask  length,  address> 

MNE:  (move  into  a  numeric  edited  field).  First  the 
edit  mask  is  loaded  into  the  receiving  field,  and  then  the 
Information  is  loaded.  Any  decimal  point  alignment  required 
will  he  performed.  Truncation  of  significant  digits  will  not 
set  the  overflow  flag.  The  program  counter  is  incremented  by 
twelve . 

Parameters:  <to  address>  <from  address>  <address  length  of 
move>  <edit  mask  address>  <address  mask  length>  <byte  to  de¬ 
cimal  count>  <byte  from  decimal  count> 

MOV :  (move  into  an  alphanumeric  field).  The  memory 
field  given  by  the  <to  address>  is  filled  by  the  from  field 
for  the  <move  length>  and  then  filled  with  blanks  in  the 
following  positions  for  the  <flll  count>. 

Parameters:  <to  address>  <from  address>  <address  move 
length>  <address  fill  count> 

STI:  (store  immediate  register  two).  The  contents  of 
register  two  are  stored  into  register  zero  and  the  decimal 
count  and  sign  indicators  are  set. 

Parameters:  none. 

The  store  instructions  are  grouped  in  the  same  order 
as  the  load  instructions.  Register  two  is  stored  into 
memory  at  the  indicated  location.  Alignment  is  performed 
and  any  truncation  of  leading  digits  causes  the  overflow 
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flag  to  be  set.  All  six  of  the  store  Instructions  cause 
the  program  counter  to  be  incremented  by  four.  The  format 
for  these  instructions  is  as  follows. 

Parameters:  <address  to  store  into>  <byte  length>  <byte  de¬ 
cimal  count> 

STO:  (store  numeric).  Store  into  a  numeric  field. 

ST1 :  (store  postfix  numeric).  Store  into  a  numeric 
field  with  an  Internal  trailing  sign. 

ST2:  (store  prefix  numeric).  Store  into  a  numeric 
with  an  Internal  leading  sign. 

ST3:  (store  separated  postfix  numeric).  Store  into  a 
numeric  field  with  a  separate  trailing  sign. 

ST4:  (store  separated  prefix  numeric).  Store  into  a 
numeric  field  with  a  separate  leading  sign. 

STS:  (store  packed  numeric).  Store  into  a  packed 
numeric  field. 

5.  Input-Output 

The  following  instructions  perform  input  and  output 
operations.  Tiles  are  defined  as  having  the  following 
characteristics:  they  are  either  sequential  or  random 
and*  in  general*  files  created  in  one  mode  are  not  required 
to  be  readable  in  the  other  mode.  Standard  files  consist 
of  fixed  length  records,  and  variable  length  files  need  not 
be  readable  in  a  random  mode.  Further,  there  must  be 
some  character  or  character  string  that  delimits  a  variable 


length  record. 

ACC:  (accept).  Read  from  the  system  input  device 

into  memory  at  the  location  given  by  the  <memory  address>. 
The  program  counter  is  incremented  by  three. 

Parameters:  <memory  address>  <byte  length  of  read> 

CIS:  (close).  Close  the  file  whose  file  control 
block  is  addressed  by  the  <fcb  address>.  The  program  counter 
is  incremented  by  two. 

Parameters:  <fcb  address> 

DIS:  (display).  Print  the  contents  of  the  data  field 
pointed  to  by  <memory  address>  on  the  system  output  device 
for  the  indicated  length  and  advance  the  line  output  if 
<flag>  is  set.  The  program  counter  is  incremented  by  four. 
Parameters:  <memory  address>  <byte  length>  <flag> 

There  are  three  open  instructions  with  the  same  for¬ 
mat.  In  each  case,  the  file  defined  by  the  file  control 
block  referenced  will  be  opened  for  the  mode  indicated.  The 
program  counter  is  incremented  by  two. 

Parameters:  <fcb  address> 

OPN:  (open  a  file  for  input). 

OP1:  (open  a  file  for  output). 

0P2:  (open  a  file  for  both  input  and  output).  This 
is  only  valid  for  files  on  a  random  access  device. 

The  following  file  actions  all  share  the  same  for¬ 
mat.  lach  performs  a  file  action  on  the  file  referenced  by 
the  file  control  block.  The  record  to  be  acted  upon  is 


given  by  the  <record  address>.  The  program  counter  is  in¬ 
cremented  by  six. 

Parameters:  <FCB  address>  <record  address>  <recerd  length  - 

address>. 

DLS:  (delete  a  record  from  a  sequential  file).  Re¬ 
move  the  record  that  was  Just  read  from  the  file.  The  file 
is  required  to  be  open  in  the  input-output  mode. 

RDF:  (read  a  sequential  file).  Read  the  next  record 
into  the  memory  area. 

VTF:  (write  a  record  to  a  sequential  file).  Append  a 
new  record  to  the  file. 

RTL:  (read  a  variable  length  record). 

WVI:  (write  a  variable  length  record). 

RWS:  (rewrite  sequential).  The  rewrite  operation 
writes  a  record  from  memory  to  the  file,  overlaying  the  last 
record  that  was  read  from  the  device.  The  file  must  be  open 
in  the  input-output  mode. 

The  following  file  actions  require  random  files 
rather  than  sequential  files.  They  make  use  of  a  random  file 
pointer  which  consists  of  a  <relative  address>  and  a  Re¬ 
lative  length>.  The  memory  field  holds  the  number  to  be 
used  in  disk  operations  or  contains  the  relative  recorl 
number  of  the  last  disk  action.  The  relative  record  number 
is  an  index  into  the  file  which  addresses  the  record  being 
accessed.  After  the  file  action,  the  program  counter 
is  Incremented  by  nine. 
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Parameters:  <ECB  address>  <record  address>  <record  length  - 
address>  <relative  address>  <relative  length  -  byte>. 

DIR:  (delete  a  random  record).  Delete  the  record  ad¬ 
dressed  by  the  relative  record  number. 

RRR:  (read  random  relative).  Read  a  random  record 
relative  to  the  record  number. 

RRS:  (read  random  sequential).  Read  the  next  sequen¬ 
tial  record  from  a  random  file.  The  relative  record  number 
of  the  record  read  Is  loaded  Into  the  memory  reference. 

RWR:  (rewrite  a  random  record). 

WRR:  (write  random  relative).  Write  a  record  into 
the  area  Indicated  by  the  memory  reference. 

WRS :  (write  random  sequential).  Write  the  next 
sequential  record  to  a  random  file.  The  relative  record 
number  Is  returned. 

6.  Subroutine  Instructions 

The  next  three  Instructions  are  used  to  transfer 
control  to  a  subroutine  and  pass  the  location  of  formal 
parameters . 

EXT:  (exit  subroutine).  The  program  counter  Is  set 
to  the  last  value  on  the  return  stack  and  the  actual 
partameters  on  the  parameter  stack  are  removed  revealing  any 
parameters  that  may  be  needed  in  the  calling  procedure. 
Parameters:  Ho  parameters  are  required. 

SBR :  (call  a  subroutine).  The  program  counter  is 


set  to  the  beginning  address  of  the  called  procedure.  The 
return  address  is  added  to  the  return  stack. 

Parameters:  procedure  name-8  bytes> 

PAR:  (parameter  list).  The  parameters  are  added  to 
the  parameter  stack. 

Parameters:  <number  of  parameters>  <address  parameter  1> 
<address  parameter  2>  . 

7.  Special  Instructions 

The  remaining  instructions  perform  special  functions 
required  by  the  machine  that  do  not  relate  to  any  of  the 
previous  groups. 

NEG:  (negate).  Complement  the  value  of  the  branch 

flag. 

Parameters:  No  parameters  are  required. 

LEI:  (load  a  code  address  direct).  Load  the  code 
address  located  five  bytes  after  the  LEI  instruction  with 
the  contents  of  <memory  address>  after  it  has  been  converted 
to  binary. 

Parameters:  <memory  address>  <length  -  byte> 

SCR:  (calculate  a  subscript).  Load  the  subscript 
stack  with  the  value  indicated  from  memory.  The  address 
loaded  into  the  stack  is  the  <lnltial  address>  plus  an 
offset.  Multiplying  the  <field  length>  by  the  number  in  the 
<memory  reference>  gives  the  offset  value. 

Parameters:  <initial  address>  <field  length>  <memory  refer- 


92 


ence>  <memory  length>  <stack  level> 

STD:  (stop  display).  Display  the  indicated  informa¬ 
tion  and  then  terminate  the  actions  of  the  machine.  The 
operator  is  given  a  choice  to  allow  the  machine  to  continue 
or  to  terminate  its  actions. 

Parameters:  <memory  address>  <length  -  byte> 

STP:  (stop).  Terminate  the  actions  of  the  machine. 
The  following  instructions  are  actually  instructions  to  the 
build  program  in  setting  up  the  machine  envlromnent  and  are 
not  used  in  the  normal  execution  of  the  machine. 

Parameters:  no  parameters  are  required. 

BST:  (backstuff).  Resolve  a  reference  to  a  label. 
Labels  may  be  referenced  prior  to  their  definition,  requir¬ 
ing  a  chain  of  resolution  addresses  to  be  maintained  in  the 
code.  The  latest  location  to  be  resolved  is  maintained  in 
the  symbol  table  and  a  pointer  at  that  location  indicates 
the  next  previous  location  to  be  resolved.  A  zero  pointer 
indicates  no  prior  occurrences  of  the  label.  The  code  ad¬ 
dress  referenced  by  <change  address>  is  examined  and  if 
it  contains  zero,  it  is  loaded  with  the  <new  address>.  If 
it  is  not  zero,  then  the  contents  are  saved,  and  the 
process  is  repeated  with  the  saved  value  as  the  change  ad¬ 
dress  after  loading  the  <new  address>. 

Parameters:  <change  address>  <nev  address> 

INT:  (initialize  memory).  Load  memory  with  the  On- 
put  strlng>  for  the  given  length  at  the  <memory  address>. 
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Parameters:  <memory  address>  <address  length>  <input 

stri ng> 


SCD:  (start  code).  Set  the  initial  value  of  the  pro¬ 
gram  counter. 

Parameters:  <start  address> 

TER:  (terminate).  Terminate  the  initialization  pro¬ 
cess  and  start  executing  code. 

Parameters:  no  parameters  are  required. 
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17.  SYSTEM  DEBUGGING  METHODS  AND  TOOLS 


A.  DEBUGGING  METHODOLOGY 

Initial  debugging  began  with  implementation  of  key 
components  of  the  compiler/interpreter  that  had  prevented 
use  of  the  Navy's  ADPESO  validation  test  programs. 
Additional  work  on  the  validation  test  programs  was 
necassary  to  eliminate  ard/or  correct  minor  errors  within 
the  test  programs  themselves.  Once  these  errors  were 
corrected  the  compiler/interpreter  was  able  to  compile  and 
execute  the  ADPESO  programs  completely  and  an  overall  view 
of  the  problems  and  errors  within  the  system  was  available 
for  analysis. 

Since  compile  time  for  each  of  the  three  main  modules  — 
PAST  ONE,  PART  TWO,  and  INTERP  —  took  a  mimimum  of 
forty-five  minutes,  a  step-wize  refinement  technique  was 
employed.  First  the  simplest  problems  were  corrected  all  at 
the  same  time.  Once  this  was  accomplished  the  remaining 
problems  were  handled  one  at  a  time  to  prevent  introducing 
new  problems  from  side  effects  of  the  corrections.  Debugging 
could  then  be  confined  to  only  one  problem  and  side  effects 
kept  to  a  minimum.  This  technique  required  more  compilations 
but  it  was  felt  that  attempting  to  correct  more  than  one 
problem  at  a  time  could  cause  severe  side  effects  with  an 
increase  in  overall  debugging  time. 
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B.  INTERACTIVE  TOOLS 


Because  the  MICRO-COBOL  compiler  and  interpreter  were 
implemented  under  the  CP/M  operating  system,  the  Symbolic 
Instruction  Debugger  [7],  SIB,  which  expands  upon  the 
features  of  the  Dynamic  Debugging  Tool  [8],  DDT,  was 
employed.  Specifically,  SID  Includes  real-time  breakpoints, 
fully  monitored  execution,  symbolic  disassembly,  assembly. 


and  memory  display  and  fill 

functions . 

One 

feature 

which 

allowed  the  setting  of 

breakpoints 

at 

actual 

memory 

locations  corresponding  to  a  program's  source  lines  and 

/, 

symbolic  names  was  used  quite  extensively.  Another  useful 
facility  was  the  ability  to  display  and  alter  the  programs 
symbolic  values,  which  enabled  the  substitution  of  values  to 
check  a  proposed  solution  to  an  error. 

C.  CROSS  REFERENCE  LISTINGS 

Another  useful  facility  which  eased  the  debugging  effort 
was  the  cross  reference  listings  produced  by  the  PLM80 
compiler  used  to  compile  the  MICRO-COBOL  compiler  and 
interpreter.  There  were  three  different  listings  produced 
after  each  compilation:  1.)  a  line  numbered  source  listing, 

2. )  a  symbol  address  table,  which  included  the  name  and 
actual  memory  address  assigned  for  all  symbols  declared,  and 

3. )  a  line  address  table  which  cross  referenced  every  line 
in  the  source  listing  with  the  8080  code  generated  by  the 
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PLM80  compiler  for  that  particular  line.  These  listings  were 
almost  Indispensable  with  regard  to  testing  and  debugging* 
and  their  contribution  cannot  be  overemphasized. 

D.  VALIDATION  TESTS 

The  primary  method  for  discovering  errors  was  the 
HTPO-COEOL  Compiler  Validation  System  (ECCVS)  Tape  (from  the 
Automated  Data  Processing  Equipment  Selection  Office 
(ADPESO)).  The  transfer  of  these  test  programs  from  tape  to 
a  usable  form  on  floppy  diskettes  was  accomplished  by  Kiefer 
and  Perry  [14l .  Additional  errors  were  discovered  through 
several  additional  test  programs  written  to  test  areas  that 
were  not  tested  by  the  ADPESO  programs  or  constructs  that 
were  not  contained  in  the  HTP0-C0B0L  specifications. 
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V.  CONCLUSIONS  AND  RECOMMENDATIONS 

The  entire  MICRO-COBOL  Compiler/Interpreter  has  been 
tested,  debugged  and  documented.  The  following  specific 
language  features  and  facilities  previously  not  implemented, 
or  Implemented  incorrectly,  have  been  successfully 
implemented,  tested  and  debugged  during  this  project:  1.) 
the  compiler's  ability  to  handle  any  sequence  of  MICRO-COBOL 
language  constructs  (PIC  CLAUSE,  VALUE  CLAUSE,  OCCURS 
CLAUSE,  and  USAGE  COMP-3  CLAUSE)  in  the  declaration  of  an 
identifier,  2.)  record  identifier  declarations  with  up  to 
ten  levels  of  elementary  field  items,  3.)  record  and 
elementary  field  identifier  redefinitions,  4.)  nested 
redefinitions,  and  5.)  error  message  generation  for 
duplicate  identifier  declarations  within  the  DATA  DIVISION, 
rework  of  the  BCD  arlthemetic  package  including  the  ROUND 
and  SIZE  ERROR  options,  7.)  implementation  of  the  Move 
Numeric  Edited  command,  8.)  implementation  of  nested 
IF-THEN-ELSE  statements,  9.)  implementation  of  the  PERFORM 
7ARTING  clause,  10.)  modification  of  all  MOVE  commands,  11.) 
modification  of  the  EXIT  clause  for  use  with  subroutines, 
12.)  modification  of  the  STOP  DISPLAT  clause  to  allow 
operator  restart,  13.)  Implementation  of  subroutines 
Including  the  CALL,  USING  and  LINEAGE  SECTION  clauses,  14.) 
modification  of  the  WRITE  BEFORE/AFTSR  clause,  15). 
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Implementation  of  COMP-3  and  SICK  LEADING /TRAILING  options, 
16.)  addition  of  the  list  and  code  compiler  toggles  to 
include  a  list  file  with  errors  and  lice  numbers  and  the 
capability  of  surpressing  code  generation  for  rapid  syntax 
checking,  and  17)  expansion  of  the  grammar  to  Include  the 
COMPUTE  verb,  the  logical  operators  "AND”  and  "OP.",  indexed 
files,  and  the  relational  operators  ”<",  ">",  and 

KPS  MICRO-COBOL  compiles  at  a  rate  of  approximately  500 
lines  per  minute  using  a  Z-80  microprocessor  with  a  4MHZ 
clock  on  a  standard  eight  inch  floppy  diskette,  with  the  use 
of  optional  toggles  such  as  NOSCODE  or  N0$LIST  compilation 
rate  Increases  to  approximately  700  lines  per  minute  and  a 
maximum  rate  of  approximately  900  lines  per  minute  with  both 
MOSCODE  and  NO$LIST  toggles  selected.  Memory  usage  is  kept 
to  a  minimum  through  the  use  of  overlays  thus  allowing 
fairly  complex  COBOL  programs  to  be  written  and  executed  on 
a  modest  sixe  microcomputer  system.  The  present  development 
system  is  designed  to  run  in  only  48K  of  main  memory  and  can 
run  in  as  little  as  20V  or  as  much  as  the  64K  maximum 
address  space  of  an  8080  or  Z-80  microcomputer.  These  two 
features  in  addition  to  clear  error  diagnostics  make  the  NPS 
MICRO-COBOL  compiler/interpreter  an  excellent  tool  for 
teaching  Introductory  COBOL  programming. 

NPS  MICRO-COBOL  has  been  validated  by  the  complete 
ADPSSO  validation  test  package  for  RYPO-COBOL.  In  addition 
to  the  twenty-five  test  programs  from  that  package,  several 


test  programs  designed  to  test  the  additional  features 
Implemented  which  were  not  in  HYP0-C0B0L  and  several 
application  programs  have  been  compiled  and  executed  to  the 
sum  of  approximately  50*000  lines  of  COBOL  code. 

In  addition*  the  NPS  MICRO-COBOL  compiler  documentation 
has  heec  updated.  This  documentation  includes  the  following: 
1.)  module  organization*  2.)  module  Interfaces,  3.)  memory 
organization  of  the  Interpreter,  4.)  construction  and  data 
initialization  of  the  symbol  table,  and  5.)  key  Internal 
data  structures. 

Several  areas  remain  which  could  be  Implemented  to 
enhance  the  UPS  MICRO-COBOL  compiler/interpreter  system, 
these  include:  1.)  implementation  of  the  COMPOTE  verb,  2.) 
implementation  of  multiple  Open's,  and  Close's,  3.) 
implementation  of  multi-dimensional  tables,  4.) 
implementation  of  the  logical  operators  "AMD"  and  "OF" ,  and 
5.)  implementation  of  the  optional  comparison  operators  ”<", 
>  ,  and  «  . 


APPENDIX  A  . 


NPS  MICRO- COBOL  USER'S  MANUAL 
VERSION  2.0 
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The  compiler  is  designed  to  run  on  an  8080  system  in  an 
interactive  mode  through  the  use  of  a  teletype  or  console. 
It  requires  at  least  24K  of  main  memory  and  a  mass  storage 
device  for  reading  and  writing.  The  compiler  is  composed  of 
two  parts  ,  each  of  which  reads  a  portion  of  the  input  file. 
Part  One  reads  the  input  program  to  the  end  of  the  Data 
Division  and  builds  the  symbol  table.  At  the  end  of  the  Data 
Division,  Part  One  is  overlayed  by  Part  Two  which  uses  the 
symbol  table  to  produce  the  code.  The  output  code  is  written 
as  it  is  produced  to  minimize  the  use  of  internal  storage. 

The  EXEC  Program  builds  the  core  image  for  the 
intermediate  code  and  performs  such  functions  as 
backstuffing  addresses  and  offsetting  address  in 
subroutines.  EXEC  then  copies  the  interpreter(CINTERP.COM) 
into  memory  and  transfers  control  to  the  it.  The  interpreter 
is  controlled  by  a  large  case  statement  that  decodes  the 
instructions  and  performs  the  required  actions. 
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This  section  contains  a  description  of  each  element  in 
the  language  and  shovs  simple  examples  of  their  use.  The 
following  conventions  are  used  in  explaining  the  formats: 
Elements  enclosed  in  broken  braces  <  >  are  themselves 
complete  entitles  and  are  described  elsewhere  in  the  manual. 
Elements  enclosed  in  braces  {  }  are  choices,  one  of  the 
elements  which  is  to  be  used.  Elements  enclosed  in  brackets 
[  1  are  optional.  All  elements  in  capital  letters  are 
reserved  words  and  must  be  spelled  exactly. 

User  names  are  indicated  in  lower  case.  These  names  are 
unrestricted  in  length,  however  they  must  be  unique  within 
the  first  15  characters.  The  only  other  restriction  on  user 
names  is  that  the  first  character  must  be  an  alpha 
character.  The  remainder  of  the  user  name  can  have  any 
combination  of  representable  characters  in  it. 

The  input  to  the  compiler  does  not  need  to  conform  to 
standard  COBOL  format.  Tree  form  input  will  be  accepted  as 
the  default  condition.  If  desired,  sequence  numbers  can  be 
entered  in  the  first  six  positions  of  each  line.  However,  a 
toggle  needs  to  be  set  to  cause  the  compiler  to  ignore  the 
sequence  numbers . 
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The  first  character  position  on  any  line  is  used  to 


indicate  the  following:- 

♦  -  indicates  a  comment  entry. 

:  -  indicates  a  debugging  line. 

/  -  indicates  a  page  eject. 


IDENTIFICATION  DIVISION 


ELEMENTS 

IDENTIFICATION  DIVISION  Format 


FORMAT: 


IDENTIFICATION  DIVISION. 

PROGRAM-ID.  <comment>. 

[AUTHOR.  <comment>.] 

[DATE-WRITTEN.  <comment>.] 

[SECURITY.  <comment>.l 
DESCRIPTION: 

This  division  provides  information  for  program  iden¬ 
tification  for  the  reader.  The  order  of  the  lines  is 
fixed. 

EXAMPLES : 

IDENTIFICATION  DIVISION. 

PROGRAM-ID.  SAMPLE. 

AUTHOR.  HAL  R  POWELL. 
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ENVIRONMENT  DIVISION 


ELEMENT : 

ENVIRONMENT  DIVISION  Format 
FORMAT: 

[  ENVIRONMENT  DIVISION. 

CONFIGURATION  SECTION. 

SOURCE-COMPUTER.  <comment>  [DEBUGGING  MODE]  . 
OBJECT-COMPUTER.  <comment>. 

[INPUT-OUTPUT  SECTION. 

FILE-CONTROL. 

<f ile-control-entry>  .  .  . 

[  I -0 -CONTROL. 

SAME  file-name-1  file-name-2  [file-name-3] 

[f ile-name-4]  [file-name-5].  Ill 

DESCRIPTION: 

This  division  determines  the  external  nature  of  a 
file.  In  the  case  of  CP/M  all  of  the  files  used  can  be 
accessed  either  sequentially  or  randomly  ezcept  for 
variable  length  files  which  are  sequential  only.  The 


debugging  mode  is  also  set  by  this  section.  The 
DEBUGGING  MODE  clause  is  used  in  conjunction  with  the 
to  Indicate  conditional  compilation  If  this 
clause  Is  specified  all  debugging  lines  (those  with  a 
in  column  one)  are  compiled.  If  this  clause  is  not 
specified,  all  debugging  lines  are  treated  as 
comments.  In  addition  the  DEBUGGING  MODE  can  be 
specified  by  using  the  compiler  toggle  'D'. 


<file-control-entry> 


ELEMENT: 

<f ile-control-entry> 
fORMAT: 

1. 

SELECT  file-name 

ASSIGN  implementor-name 
[ORGANIZATION  SEQUENTIAL] 

[ACCESS  SEQUENTIAL], 

2. 

SELECT  file-name 

ASSIGN  implementor-name 
ORGANIZATION  RELATIVE 

[ACCESS  [SEQUENTIAL  [RELATIVE  da ta-name] }] . 
[RANDOM  RELATIVE  data-name  > 

3. 

SELECT  file-name 
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ASSIGN  implementor-name 


ORGANIZATION  INDEXED 
[ACCESS  {SEQUENTIAL}]  . 
{RANDOM  } 


DESCRIPTION: 

The  file-control-entry  defines  the  type  of  file  that 
the  program  expects  to  see.  There  is  no  difference  on 
the  diskette,  but  the  type  of  reads  and  writes  that 
are  performed  will  differ.  Tor  CP/M  the  implementor 
name  needs  to  conform  to  the  normal  specifications. 
Indexed  is  not  Implemented. 

EXAMPLES : 

SELECT  CARDS 

ASSIGN  CARD.FIL. 

SELECT  RANDOM-PILE 

ASSIGN  A. RAN 

ORGANIZATION  RELATIVE 


ACCESS  RANDOM  RELATIVE  RAND-FLAG 


ELEMENT: 


DATA  DIVISION  Format 

FORMAT: 

DATA  DIVISION. 

[FILE  SECTION. 

[FD  file-name 

[BLOCK  integer-1  RECORDS] 

[RECORD  [integer-2  TO]  integer-3] 

[LABEL  RECORDS  {STANDARD}] 

(OMITTED  } 

[VALUE  OF  lrpleirentor-name-1  literal-1 
[implement or-n a me-2  literal-2]  ...  ]. 
[<record-description-entry>]  . . .]  ... 
[WORKING-STORAGE  SECTION. 
[<record-description-entry>]  ...  ] 


[LINKAGE  SECTION 


[<recor4-4escrlption-entry>]  ...  ] 

DESCRIPTION: 

This  Is  the  section  that  4escrihes  hov  the  4ata  is 
structure4.  There  are  no  major  4ifferences  from  stan- 
4ar4  COBOL  except  for  the  following:  1.  Label 
recor4s  make  no  sense  on  the  41skette  so  no  entry  Is 
required.  2.  The  VALUE  OF  clause  likewise  has  no 
meaning  for  CP/M.  If  a  recor4  Is  given  two  lengths  as 
in  RECORD  12  TO  128,  the  file  Is  taken  to  be  variable 
length  and  can  only  be  accessed  In  the  sequential 
mode.  See  the  section  on  files  for  more  information. 
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.  -a**.  r.Wi 


<comment> 


ELEMENT: 

<comment> 

FORMAT: 


an/  string  of  characters 
DESCRIPTION: 

A  comment  is  a  string  of  characters.  It  ira/  Include 
anything  other  than  a  period  followed  by  a  blank  or  a 
reserved  word,  either  of  which  terminate  the  string. 
Comments  may  be  empty  if  desired,  but  the  terminator 
is  still  required  by  the  program. 

EXAMPLES : 

this  is  a  comment 

another oneallrun together 

8080b  16E 
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<data-description-entry> 


ELEMENT: 

<data-descrlption-entry>  Eormat 
FORMAT: 

level-number  {data-name} 

{FILLER  } 
[REDEFINES  data-name] 

[PIC  character-string] 

[USAGE  [COMP  }] 

[COMP-j5> 

[COMPUTATIONAL] 

{DISPLAY} 

[SIGN  {LEADING}  [SEPARATE]] 
{TRAILING} 

[OCCURS  integer] 

[SYNC  [LEFT  ]] 

[RIGHT] 
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[VALUE  literal] 


DESCRIPTION: 

This  statement  describes  the  specific  attributes  of 
the  data.  Since  the  8080  is  a  byte  machine,  there  was 
no  meaning  to  the  STNC  clause,  and  thus  it  has  not 
been  implemented,  however  existing  programs  that  are 
transfered  to  MICRO-COBOL  and  use  this  feature  will 
compile  and  execute  successfully.  All  numeric  data  are 
maintained  in  DISPLAT  format  or  packed  BCD  if  the 
COMP-3  option  is  used. 

EXAMPLES : 

01  CARD-RECORD. 

02  PART  PIC  1(5). 

02  NEXT-PART  PIC  99V99  USAGE  DISPLAY. 


02  FILLER. 

03  NUMB  PIC  S9(3)V9  SIGN  LEADING  SEPARATE . 
03  LONG-NUMB  9(15). 

03  STRING  REDEFINES  LONG-NUMB  PIC  X(15). 

02  ARRAY  PIC  99  OCCURS  100. 
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PROCEDURE  DIVISION 


ELEMENT: 

PROCEDURE  DIVISION  format 


fORMAT: 

1. 


PROCEDURE  DIVISION  [USING  namel  [name?]  . 
section-name  SECTION. 

[paragraph-name.  <sentence>  [<sentence>  . 


2. 


PROCEDURE  DIVISION  [USING  namel  [name?]  . 
paragraph-name.  <sentence>  [<sentence>  .. 
DESCRIPTION: 


.  [names]]. 

•  ]  ...  ]  ... 

.  [names]]. 

1  ... 


As  Is  Indicated,  if  the  program  Is  to  contain  sec¬ 
tions,  then  the  first  paragraph  must  he  in  a  section. 


<sentence> 


i 

ELEMENT : 

<sentence> 


FORMAT : 

<imperative-sta  tement> 
<conditlonal-statement> 
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<imperative-statement> 


ELEMENT: 

<imperative-statement> 

FORMAT : 

The  following  verbs  are  always  imperatives: 

ACCEPT 

CALL 

CLOSE 

DISPLAY 

EXIT 

SO 

MOTE  i 

OPE* 

PERFORM 

STOP 

The  following  may  be  imperatives: 

arithmetic  verbs  without  the  SIZE  ERROR  statement 

and  DELETE,  WRITE,  and  REWRITE  without  the  INVALID  option. 
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<conditlonal-statements> 

ILIMIHT: 

<conditional-statements> 

FORMAT: 

IF 

READ 

arithmetic  verbs  with  the  SIZE  ERROR  statement 

and  DELETE,  WRITE,  and  REWRITE  with  the  INVALID  option. 


ACCEPT 


ELEMENT: 

ACCEPT 


fORMAT: 


ACCEPT  <identif ier> 

DESCRIPTION: 

This  statement  reads  up  to  255  characters  from  the 
console.  The  usage  of  the  item  must  he  DISPLAT. 
EXAMPLES : 

ACCEPT  IMMAGE. 

ACCEPT  NUM(9). 
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ELEMENT : 


ADD 


FORMATS 


ADD  {ldentifier-1}  [{identifier-2  }]  ...  TO  identifier-m 
{literal-1  }  {literal-2  } 

[ROUNDED]  [SIZE  ERROR  <imperat ive-statement>] 
DESCRIPTIONS 

This  instruction  adds  either  one  number  to  a 
second  with  the  result  bein*  placed  in  the  last  loca¬ 
tion.  Multiple  adds  have  not  been  implemented. 

EXAMPLES  s 

ADD  10  TO  NUMB1 

ADD  X  TO  Z  ROUNDED. 

ADD  100  TO  NUMBER  SIZE  ERROR  GO  ERROR-LOC 


CALL 


ELEMENT: 

CALL 


EORMAT: 


CALL  literal  [USING  namel  [name2]  ...  [nameN-)] 
DESCRIPTION: 

Control  is  transfered  to  the  called  procedure  with  an 
address  of  each  of  the  parameters  to  he  passed.  The 
parameters  map  to  those  in  the  linkage  section  of  the 
called  program.  The  type  and  size  of  the  parameters 
must  match  exactly. 

EXAMPLES : 

CALL  'NCI 52'  USING  DN1 
CALL  'PRINT' 

CALL  'ADDLIST'  USING  VAR1  ¥AR2  VAR3 


CLOSE 


ELEMENT: 

CLOSE 

FORMAT: 

CLOSE  file-name 
DESCRIPTION: 

Piles  must  be  closed  if  they  have  been  written.  How¬ 
ever,  the  normal  requirement  to  close  an  input  file 
prior  to  the  end  of  processing  does  not  exist. 

EXAMPLES : 

CLOSE  FILE1 

CLOSE  RANDFILE 
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DELETE 


ELEMENT : 

DELETE 
FORMAT : 

DELETE  file-name  [INVALID  <imperative-statement>l 
DESCRIPTION: 

This  statement  requires  the  file-name  of  the  item 
to  he  deleted.  The  record  is  logically  removed  hy 
filling  it  with  a  high  value  character,  which  is  not 
dlsplayable  to  the  console  or  line  printer.  The  log¬ 
ical  record  space  can  he  used  again  by  writing  a 
valid  record  in  its  place. 

EXAMPLES: 

DELETE  PILE-NAME 
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DISPLAY 


ELEMENT: 

DISPLAY 


PORMAT: 


DISPLAY  {identifier}  [{identif ier-l}l  .  .  .  [{identifier- 
{literal  }  {literal-1  }  ...  {literal-N 

DESCRIPTION: 

This  displays  the  contents  of  an  identifier  or 
displays  a  literal  on  the  console.  Usage  trust  be 
DISPLAY.  The  maximum  length  of  the  display  is  80  char¬ 
acters  for  literal  values  and  255  characters  for 
identifiers. 

EXAMPLES : 

DISPLAY  MESSAGE-1 

DISPLAY  MESSAGE-3  10 

DISPLAY  'THIS  MUST  BE  THE  END' 


DIVIDE 


ELEMENT: 

DIVIDE 

FORMAT: 

DIVIDE  {identifier}  INTO  identifier-1  [ROUNDED] 
{literal  } 

[SIZE  ERROR  <imperative-statement>] 

DESCRIPTION: 

The  result  of  the  division  is  stored  in  identifler-i; 
any  remainder  is  lost. 

EXAMPLES: 

DIVIDE  NtJMB  INTO  STORE 
DIVIDE  25  INTO  RESULT 


126 


EXIT 


ELEMENT: 

EXIT 

EORMAT: 

EXIT  [PROGRAM] 

DESCRIPTION : 

The  EXIT  command  causes  no  action  by  the  interpreter 
hut  allows  for  an  empty  paragraph  for  the  construction 
of  a  common  return  point.  The  optional  PROGRAM  termi¬ 
nates  a  subroutine  and  returns  to  the  calling  program. 
It's  use  in  the  main  program  couses  no  action  to  he 
taken. 

EXAMPLES : 

EXIT  PROGRAM 

EXIT 
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GO 


ELEMENT: 

GO 

PORMAT: 

1. 

GO  procedure-name 

2. 

GO  procedure-1  [procedure-2]  ...  procedure-20 
DEPENDING  Identifier 
DESCRIPTION: 

The  GO  command  causes  an  unconditional  branch 
routine  specified.  The  second  form  causes  a 
branch  depending  on  the  value  of  the  contents 
identifier.  The  identifier  must  be  a  numeric 
value.  There  can  be  no  more  than  20  procedure 
EXAMPLES : 

GO  READ-CARD. 


to  the 

forward 

of  the 
integer 
names . 
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GO  RSAD1  READ2  READS  DEPENDING  READ-INDEX 
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IP 


ELEMENT: 

IP 

FORMAT: 

IF  <condition>  {stmt-lst  >  END-IF 

IF  <condition>  {stmt-lst  >  ELSE  {stmt-lst}  END-I? 

{NEXT  SENTENCE}  {NEXT  SENTENCE} 

DESCRIPTION: 

This  is  an  enhanced  version  of  the  standard  COBOL  IP 
statement.  Nesting  of  IF  statements  is  allowed. 

EXAMPLES : 

IF  A  GREATER  B  ADD  A  TO  C  ELSE  GO  ERROR-ONE  END-IP. 

IF  A  NOT  NUMERIC  NEXT  SENTENCE  ELSE  MOTE  ZERO  TO  A  END-IF. 
IF  A  LESS  B 
DISPLAY  A 
DISPLAY  B  END-IF. 

IF  A  GREATER  B 
DISPLAY  A 
DISPLAY  B 
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ELSE 


DISPLAT  C 
DISPUT  D  END-IP. 
IP  A  GREATER  B 
IP  A  GREATER  C 
DISPLAT  A 
ELSE 

DISPUT  C 
END-IP 
ELSE 

IP  B  GREATER  C 
DISPLAT  B 
ELSE 

DISPLAT  C 
END-IP 
END-IP. 
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MOVE 


ELEMENT: 

MOVE 


EORMAT: 


MOVE  {identifier-1}  TO  identifier-2 
{literal  } 


DESCRIPTION: 

The  standard  list  of  allowable  moves  applies  to  this 
action.  As  a  space  saving  feature  of  this  implementa¬ 
tion,  all  numeric  moves  go  through  the  accumulators. 
This  makes  numeric  moves  slower  than  alpha-numeric 
moves,  and  where  possible  they  should  be  avoided.  Any 
move  that  Involves  picture  clauses  that  are  exactly 
the  same  can  be  accomplished  as  an  alpha-numeric  move 
if  the  elements  are  redefined  as  alpha-numeric?  also 
all  group  moves  are  alpha-numeric. 

EXAMPLES: 

MOVE  SPACE  TO  PRINT-LINE. 

MOVE  A(10)  TO  P{PTR) . 
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MULTIPLY 


ELEMENT: 

MULTIPLY 


EORMAT : 


MULTIPLY  {identifier}  BY  identifier-2  [ROUNDED] 
{literal  } 

[SIZE  ERROR  <imperative-statement>] 

DESCRIPTION: 

The  multiply  routine  uses  a  double  length  register  to 
calculate  the  result.  This  allows  the  result  generated 
to  be  of  maximum  precision.  The  actual  value  stored 
will  be  determined  by  the  amount  of  storage  allocated 
for  the  variable.  Overflow  will  occur  if  the  number  in 
the  register  is  larger  than  the  variable.  If  the 
precision  in  the  register  is  greater  than  the  variable 
trucatlon  occurs  unless  the  round  option  is  specified. 
EXAMPLES : 

MULTIPLY  X  BY  Y. 

MULTIPLY  A  BY  B(7)  SIZE  ERROR  00  OVERTLOW. 


OPEN 


ELEMENT: 

OPEN 


FORMAT : 


OPEN  {INPUT  file-name-1  }  [{file-name-2}]  ... 
{OUTPUT  file-name-1}  [{file-name-2}]  ... 
{ I  — 0  file-name-1  }  [{file-name-2}]  ... 


DESCRIPTION: 

The  three  types  of  OPENS  have  exactly  the  same  effect 
on  the  diskette.  However,  they  do  allow  for  internal 
checking  of  the  other  file  actions.  For  example,  a 
write  to  a  file  set  open  as  input  will  cause  a  fatal 
error.  Multiple  opens  have  not  been  implemented. 
EXAMPLES : 

OPEN  INPUT  CARDS. 

OPEN  OUTPUT  REPORT-FILE. 


PERFORM 


ELEMENT: 

PERFORM 

FORMAT: 

1. 

PERFORM  procedure-name  [THRU  procedure-name-2] 

2. 

PERFORM  procedure-name  [THRO  procedure-name-2] 
{identifier}  TIMES 
{integer  } 

3. 

PERFORM  procedure-name  [THRU  procedure-name-2] 

I 

UNTIL  <condition> 


PERFORM  procedure-name  FARTING  {identifier} 

v 

FROM  {identifier}  BT  {identifier} 


UNTIL  <condition> 


DESCRIPTION : 

All  four  options  are  supported.  Branching  may  he  ei¬ 
ther  forward  or  backward,  and  the  procedures  called 
may  have  perform  statements  in  them  as  long  as  the  end 
points  do  not  coincide  or  overlap. 

EXAMPLES : 

PERFORM  OPEN-ROUTINE. 

PERFORM  TOTALS  THRU  END-REPORT. 

PERFORM  SUM  10  TIMES. 

PERFORM  SXIP-LINE  UNTIL  PG-CNT  GREATFR  60. 

PERFORM  REPEAT-AGAIN  VARYING  COUNTER  FROM  1  BY  2 


UNTIL  COUNTER  EQUAL  10 


READ 


ELEMENT: 

READ 


EORMAT: 

1. 


READ  file-name  INVALID  <imperative-statement> 


2i 


READ  file-name  END  <imperative-statement> 

DESCRIPTION: 

The  invalid  condition  is  only  applicable  to  files  in  a 
random  mode.  All  sequential  files  must  have  an  END 
statement . 

EXAMPLES : 

READ  CARDS  END  GO  END-OF-EILE. 

READ  RANDOM-EILE  INVALID  MOVE  SPACES  TO  REC-1 . 


REWRITE 


ELEMENT: 

REWRITE 


FORMAT: 


REWRITE  record-name  [INVALID  <imperative>} 

DESCRIPTION: 

REWRITE  is  only  valid  for  files  that  are  open  in  the 
1-0  mode.  The  INVALID  clause  is  only  valid  for  random 
files.  This  statement  results  in  the  current  record 
being  written  bach  into  the  place  that  it  was  Just 
read  from,  the  last  executed  read. 

EXAMPLES : 

REWRITE  CARDS. 

REWRITE  RAND-1  INVALID  PERFORM  ERROR-CHECK. 


STOP 


ELEMENT: 

STOP 


FORMAT: 


STOP  {RUN  > 
{literal} 


DESCRIPTION: 

This  statement  stops  execution  of  the  program.  If  a 
literal  is  specified,  then  the  literal  is  displayed  on 
the  console  and  a  prompt  is  displayed  giving  the 
operator  the  option  of  terminating  or  continuing 
program  execution. 

EXAMPLES : 

STOP  RUN. 

STOP  1. 

STOP  'INVALID  FINISH'. 

For  the  last  two  examples  the  following  prompt  is 
displayed: 

OPERATOR  ENTER  A  <CR>  TO  CONTINUE 
OR  ENTER  AN  ”s”  TO  TERMINATE. 
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SUBTRACT 


ELEMENT: 

SUBTRACT 


EORMAT: 


SUBTRACT  {iaentifler-1}  [identifier-2]  ...  FROM  ldentlfler-m 
{literal-1  >  [literal-2  ] 

[ROUNDED]  (SIZE  ERROR  <inperative-statement>] 

DESCRIPTION: 

Identlf  ier-tn  is  decremented  by  the  value  of 
identifier/literal  one.  The  results  are  stored  back 
in  identlf ier-m.  Rounding  and  site  error  options  are 
available  if  desired.  Multiple  subtracts  have  not  been 
implemented. 

EXAMPLES : 

SUBTRACT  10  FROM  SUB(12). 

SUBTRACT  A  FROM  C  ROUNDED. 


WHITE 


ELEMENT: 

WHITE 


FORMAT: 

1. 


WRITE  record-name  [{BEFORE}  ADVANCING  {INTEGER}] 

{AFTER  }  {PAGE  } 


2. 


WRITE  record-name  INVALID  <imperatlve-statement> 
DESCRIPTION: 

The  record  specified  is  written  to  the  file 
specified  In  the  file  section  of  the  source 
program.  The  INVALID  option  only  applies  to 
random  files. 

EXAMPLES : 

WRITE  OUT-FILE. 

WRITE  RAND-FILE  INVALID  PERFORM  ERROR-RECOV. 
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<condltion> 


ELEMENT: 

<condltlon> 


FORMAT: 

RELATIONAL  CONDITION: 

{identlfier-1}  [NOT]  {GREATER}  {ldentifier-2} 
{literal-1}  {LESS  }  {literal-2  } 

{EQUAL  } 

CLASS  CONDITION: 

identifier  [NOT]  {NUMERIC  } 

{ALPHABETIC} 


DESCRIPTION: 

It  is  not  valid  to  compare  two  literals.  The  class 
condition  NUMERIC  will  allow  for  a  sign  if  the  iden¬ 
tifier  is  signed  numeric. 

EXAMPLES: 

A  NOT  LESS  10. 

LINE  GREATER  'C\ 


NUMB1  NOT  NUMERIC 


Subscripting 


ELEMENT: 

Subscripting 

FORMAT: 

data-came  (subscript) 

DESCRIPTION: 

Any  item  defined  with  an  OCCURS  may  be  referenced  by 
a  subscript.  The  subscript  may  be  a  literal  integer* 
or  It  may  be  a  data  item  that  has  been  specified  as  an 
integer.  If  the  subscript  is  signed,  the  sign  must  be 
positive  at  the  time  of  its  use. 

EXAMPLES : 

A(  10 ) 


ITEM(SUB) 


III.  compiler  toggles 


There  are  six  compiler  toggles  which  are  controlled  by 
an  entry  following  the  compiler  activation  command,  COBOL 
<filename>.  The  format  of  the  entry  consists  of  following 
<fllename>  hy  one  space  and  then  entering  a  followed 
immediately  by  the  desired  toggles.  There  must  be  only  one 
space  after  <filename>  and  no  spaces  between  the  and  the 
toggles.  The  following  is  an  example  of  a  typical  entry: 

COBOL  EXAMPLE  $S 

This  entry  would  cause  the  compiler  to  ignore  the  first  six 
characters(used  for  sequence  numbers)  at  the  beginning  of 
each  input  line.  In  each  case  the  toggle  reverses  the 
default  value. 

$C  —  No  Intermediate  code.  Default  is  off.  Setting  this 
toggle  speeds  initial  compilation  for  syntax  checking.  When 
this  toggle  is  set  the  "CIN"  file  is  empty. 

$D  —  Debugging  mode.  Default  is  off.  This  toggle  sets 
the  debugging  mode,  which  means  all  debugging  lines( those 
with  a  in  column  one)  are  compiled.  If  this  toggle  is 
not  set  and  the  DEBUGGING  MODE  is  not  set  in  the  ENVIRONMENT 
DIVISION  of  the  source  program  all  debugging  lines  are 
treated  as  comments. 

$L  —  list  the  input  code  on  the  screen  as  the  program 
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Is  compiled.  Default  is  on.  Error  messages  are  displayed  at 
the  terminal  in  any  case. 

$P  —  Productions.  List  productions  as  they  occur. 
Default  is  off. 

$S  —  sequence  numbers  are  in  the  first  six  positions  of 
each  record.  Default  is  off. 

$T  --  Tokens.  List  tokens  from  the  scanner.  Default  is 

off. 

$V  —  Create  a  list  file.  Default  is  off.  A  listing  file 
is  created  when  this  toggle  is  set.  When  this  toggle  is  not 
set  the  “LST"  file  will  only  contain  error  messages. 
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17.  RUN  TIME  CONVENTIONS 


This  section  explains  how  to  run  the  compiler  on  the 
current  system.  The  compiler  expects  to  see  a  file  with  a 
type  of  CBL  as  the  input  file.  In  general,  the  input  is  free 
form.  If  the  input  includes  sequence  numbers  then  the 
compiler  must  he  notified  by  setting  the  appropriate  toggle. 
The  compiler  is  started  by  typing  COBOL  <file-name>.  Where 
the  file  name  is  the  system  name  of  the  input  file.  There  is 
no  interaction  required  to  start  the  second  part  of  the 
compiler.  The  output  file  will  have  the  same  <file-name'>  as 
the  input  file,  and  will  be  given  a  file  type  of  CIN.  Any 
previous  copies  of  the  file  will  be  erased.  As  with  the  CIN 
file  a  1ST  file  will  be  created  with  the  same  file  name  as 
the  input  file  and  any  previous  LST  files  with  that  name 
will  be  erased. 

The  Interpreter  is  started  by  typing  EXEC  <filename>. 
The  first  program  is  a  loader,  and  it  will  display  "NPS 
MICRO-COBOL  LOADER  VERS  1.0"  followed  by  the  display  "LOAD 
TINISHED"  to  Indicate  successful  completion.  The  run-time 
package  will  be  brought  in  by  the  EXEC  routine,  and 
execution  should  continue  without  interruption.  Succesful 
transfer  of  control  to  the  Interpreter  will  be  indicated  by 
the  display  "NPS  MICRO-COBOL  INTERPRETER  VERS  1.0”. 
Completion  of  program  exaction  will  be  indicated  by  the 
display  ”  X  EXECTION  ERROR(S)”,  where  ”x”  is  the  number  of 
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errors  which  occured  during  execution 


V.  FILE  INTERACTIONS  WITH  CP/M 


The  file  structure  that  is  expected  by  the  program 
imposes  some  restrictions  on  the  system.  References  4  and  5 
contain  detailed  information  on  the  facilities  of  CP/M,  and 
should  be  consulted  for  details.  The  Information  that  has 
been  included  In  this  section  Is  Intended  to  explain  where 
limitations  exist  and  how  the  program  Interacts  with  the 
system. 

All  files  in  CP/M  are  on  a  random  access  device,  and 
there  is  no  way  for  the  system  to  distinguish  sequential 
files  from  files  created  in  a  random  mode.  This  means  that 
the  various  types  of  reads  and  writes  are  all  valid  to  any 
file  that  has  fixed  length  records.  The  restrictions  of  the 
ASSIGN  -  statement  prevent  a  file  from  being  open  for  both 
random  and  sequential  actions  during  one  program. 

Each  logical  record  is  terminated  by  a  carriage  return 
and  a  line  feed.  In  the  case  of  variable  length  records, 
this  is  the  only  end  mart  that  exists.  This  convention  was 
adopted  to  allow  the  various  programs  which  are  used  in  CP/M 
to  work  with  the  files.  Files  created  by  the  editor,  for 
example,  will  generally  be  variable  length  files.  This 
convention  removes  the  capability  of  reading  variable  length 
files  in  a  random  mode. 

All  of  the  physical  records  are  128  bytes  in  length,  and 
the  program  supplies  buffer  space  for  these  records  in 
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addition  to  the  logical  records.  logical  records  may  he  of 
any  desired  length. 


VI.  ERROR  MESSAGES 


A.  COMPILER  FATAL  MESSAGES 

BP.  Bad  read  —  disk  error,  no  corrective  action  can  be 
taken  in  the  program. 

CL  Close  error  —  unable  to  close  the  output  file. 

MA  Make  error  —  could  not  create  the  output  file. 

MO  Memory  overflow  —  the  code  and  constants  generated 

will  not  fit  in  the  alloted  memory  space. 

OP  Open  error  —  can  not  open  the  input  file,  or  no  such 
file  present. 

SO  Stack  overflow  —  the  LALR(l)  parsing  stack  has  exceeded 
its  maximum  allowable  size. 

ST  Symbol  table  overflow  —  symbol  table  is  too  large  for 
the  allocated  space. 

WR  Vrite  error  —  disk  error,  could  not  write  a  code 

record  to  the  disk. 

B.  COMPILER  WARNINGS 

CC  Carriage  Control  error  —  The  WRITE  BEFORE/AFTER 

ADVANCING  option  can  only  be  used  with  sequential  files. 

CE  Close  error  —  attempted  to  close  a  non-existing  file. 
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DD  Duplicate  Declaration  —  the  identifier  name  has  been 
previously  declared. 

EL  Extra  levels  —  only  10  levels  are  allowed. 

FT  File  type  —  the  data  element  used  in  a  read  or  write 

statement  is  not  a  file  name. 

IA  Invalid  access  —  the  specified  options  are  not  an 
allowable  comoination. 

ID  Identifier  stack  overflow  —  more  than  2C  items  in  a 

GO  —  DEPENDING  statement. 

IS  Invalid  subscript  —  an  item  was  subscripted  but  it 

was  not  defined  by  an  OCCURS. 

IT  Invalid  type  —  the  field  types  do  not  match  for  this 

statement . 

LE  Literal  error  —  a  literal  value  was  assigned  to  an 

item  that  is  part  of  a  group  item  previously  assigned 
a  value. 

LV  Literal  value  error  —  the  PICTURE  clause  field  type 
does  not  match  the  VALUE  clause  literal  type. 

L7  Level  77  error  —  level  77  used  incorrectly. 

MD  Multiple  decimals  ~  a  numeric  literal  in  a  VALUE 
clause  contains  more  than  one  decimal  point. 

MS  Multiple  signs  —  a  signed  numeric  literal  in  a  VALUE 
clause  contains  more  than  one  sign. 

NF  No  file  assigned  —  there  was  no  SELECT  clause  for 

this  file. 

NI  Not  implemented  —  a  production  was  used  that  is  not 
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implemented. 

Non-numeric  —  an  Invalid  character  was  found  in  a 
numeric  string. 

NP  No  production  —  no  production  exists  for  the  cuurrent 
parser  configuration;  error  recovery  will  automatically 
occur. 

NV  Numeric  value  —  a  numeric  value  was  assigned  to  a 
non-numeric  item. 

OE  Open  error  —  attempt  to  open  a  file  that  was  not  de¬ 
clared;  or  attempted  to  open  a  file  for  1-0  that  was 
not  a  RELATIVE  file. 

OL  OCCURS  LEVEL  —  01  and  7?  levels  can  not  contain  an 
occurs  clause. 

PC  Picture  clause  —  a  pic  clause  exceeds  30  characters. 

PI  More  than  one  float  symbol  declared. 

P2  Non-numeric  data  in  repetition  clause  or  missing  right 
pa renthesls. 

P3  Invalid  or  incompatable  symbol  in  pic  clause. 

P4  Invalid  symbol(s)  embedded  within  a  float  symbol 

only  /,0,B,','  allowed. 

P5  Invalid  combination  of  symbols  in  pic  clause,  type  cannot 
be  determined. 

P6  Number  of  possible  numeric  entries  exceeds  register  length 
max  is  18. 

PP  Paragraph  first  —  a  section  header  was  produced  after 
a  paragraph  header,  which  is  not  in  a  section. 
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R1  Redefine  nesting  —  a  redefinition  was  made  for  an 
Item  which  is  part  of  a  redefined  item. 

R2  Redefine  length  —  the  length  of  the  redefinition  item 
was  greater  than  the  item  that  it  redefined.  That 
is  only  allowed  at  the  01  level.  This  error 
message  may  he  printed  out  one  identifier  past  the 
redefining  identifier  record  in  which  it  occurred. 

R3  Redefines  misplaced  —  a  redefines  was  attempted  in  the 
FILE  SECTION  of  the  source  program. 

SE  Scanner  error  —  the  scanner  was  unable  to  read  an 

identifier  due  to  an  invalid  character. 

SG  Sign  error  —  either  a  sign  was  expected  and  not 

found,  or  a  sign  was  present  when  not  valid. 

SL  Significance  loss  —  the  number  assigned  as  a  value  is 
larger  than  the  field  defined. 

TE  Type  error  —  the  type  of  a  subscript  index  is  not 
integer  numeric. 

UD  Undeclared  identifier  —  the  identifier  was  not 
declared. 

UL  Unresolved  label  —  label  has  not  been  referenced. 

This  warning  will  be  given  to  all  references  to 
external  subroutines. 

TE  Value  error  —  a  value  statement  was  assigned  to  an 
item  in  the  file  section. 

WL  Wrong  level  error  —  program  attempted  to  write  a 
record  other  than  an  01  level  record  to  an  output 
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file 


C.  INTERPRETER  FATAL  ERRORS 


CL  Close  error  ~  the  system  was  unable  to  close  an  output 
file. 

CO  Call  stack  Overflow  —  insufficient  memory  available  to 
transfer  varable  address'  and/or  return  location  for  a 
subroutine  call. 

ME  Make  error  —  the  system  was  unable  to  make  an  output 
file  on  the  disk. 

NF  No  file  —  an  input  file  with  the  given  name  could  not 
be  opened. 

OE  Open  Error  —  attempt  to  open  a  file  which  was  already 
open . 

OP  Open  Error  —  the  system  was  unable  to  open  a  file. 

PS  Procedure  Stack  —  not  enough  memory  to  load  all 

subroutines. 

SO  Subroutine  Overflow  —  subroutine  symbol  table  overflow. 

VI  Write  non-sequential  —  attempted  to  WRITE  to  a  file 
opened  for  INPUT  or  a  file  opened  for  1-0  when  ACCESS 
was  SEQUENTIAL. 

V2  Wrong  key  —  attempted  to  change  the  key  value  to  a 
lower  value  than  the  number  of  the  last  record  writ¬ 
ten. 
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W3  Write  input  —  attempted  to  WRITE  to  a  file  opened 
for  INPUT. 

W4  Write  non-empty  —  attempted  to  WRITE  to  a  non-empty 
record. 

W5  Read  output  —  attempted  to  READ  a  file  opened  for 
OUTPUT . 

W6  Rewrite  error  --  attempted  to  REWRITE  to  a  file 
not  opened  for  1-0. 

W7  Rewrite  error  —  attempted  to  REWRITE  a  record  before 
reading  the  file?  or  multiple  REWRITE  attempts  with¬ 
out  doing  a  READ  between  each. 

D.  INTERPRETER  WARNING  MESSAGES 

EM  End  mark  —  a  record  that  was  read  did  not  have  a 

carriage  return  or  a  line  feed  in  the  expected  location. 

GD  Go  to  depending  —  the  value  of  the  depending  indicator 
was  greater  than  the  number  of  available  branch 
addresses. 

IC  Invalid  character  —  an  Invalid  character  was  loaded 

into  an  output  field  during  an  edited  move.  For  example, 
a  numeric  character  into  an  alphabetic-only 
field. 

NE  Numeric  Error  —  non-numeric  data  in  an  arithmetic 
operation. 
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Write  Error  —  the  system  was  unable  to  write  to  an 
output  file  on  the  disk.  Disk  may  be  full. 

Sign  Invalid  —  the  sign  is  not  a  "+”  or  a 
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LIST  0?  MICRO-COBOL  RESERVED  WORDS 


The  following  is  a  list  of  reserved  words  for 
MICRO-COBOL.  The  reserved  words  are  the  same  as  those 
specified  for  the  HYPO-COBOL  language,  except  where  noted 
with  an  asterisk  (*). 


ACCEPT 

END-IF  * 

MODE 

ROUNDED 

ACCESS 

ENTER 

MOVE 

RUN 

ADD 

ENVIRONMENT 

MULTIPLY 

SAME 

ADVANCING 

EOF  * 

NEXT 

SECTION 

AFTER 

EQUAL 

NO  * 

SECURITY 

ALPHABETIC 

ERROR 

NOT 

SELECT 

AND  * 

EXIT 

NUMERIC 

SENTENCE 

ASSIGN 

FD 

OBJECT-COMPUTER 

SEPARATE 

AUTHOR 

FILE 

OCCURS 

SEQUENTIAL 

BEFORE 

FILE-CONTROL 

OF 

SIGN 

BLOCK 

FILLER 

OMITTED 

SIZE 

BY 

FROM 

OPEN 

SOURCE-COMPUTER 

CALL 

GIVING  * 

OR  * 

SPACE 

CLOSE 

GO 

ORGANIZATION 

STAN DARD 

COBOL 

GREATER 

OUTPUT 

STOP 

COMP 

1-0 

PAGE 

SUBTRACT 

COMP-3  * 

I-O-CONTROL 

PERFORM 

SYNC 

COMPUTATIONAL^IDENTIFICATION 

PIC 

THRU 

COMPUTE  * 

IF 

PROCEDURE 

TIMES 

CONFIGURATION 

INDEXED  * 

PROGRAM 

TO 

DATA 

INPUT 

PROGRAM-ID 

TRAILING 

DATE-WRITTEN 

INPUT-OUTPUT 

QUOTE 

UNTIL 

DEBUGGING 

INSTALLATION  * 

RANDOM 

USAGE 

DELETE 

INVALID 

READ 

USING 

DEPENDING 

INTO  * 

RECORD 

VALUE 

DISPLAY 

LABEL 

RECORDS 

VARYING  * 

DIVIDE 

LEADING 

REDEFINES 

WITH  * 

DIVISION 

LEFT 

relative 

WORKING-STORAGE 

ELSE 

LESS 

REWRITE 

WPITE 

END 

LINKAGE 

RIGHT 

ZERO 

In  addition  the  arlthemetlc 

operators. 

*•  •*  .H 

*  .  Z  *  t  and 

**  ,  and  the 

comparison  operators  >  ,  < 

and  ■  are  in 

the  reserved  word  list.  None  of  these  symbols  are  in  in  HYPO 
COBOL  but  have  been  added  to  the  grammar  of  NPS  MICP.O-COBOL 


to  enable  greater  flexiblity 
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APPENDIX  C 


The  MICRO-COBOL  compiler  and  interpreter  source  files 
currently  exist  in  the  high  level  language  PLM80  and  are 
edited  and  compiled  under  the  ISIS  operating  system  on  a 
INTEL  Corporation  MDS  system.  This  is  a  description  of  the 
procedures  required  to  compile  and  establish  the  programs  to 
compile  and  interpret  a  MICRO-COBOL  program.  The  MICRO-COBOL 
compiler/interpreter  runs  on  any  8080  or  Z-82  based 
microcomputer  that  operates  under  CP/M.  The  execution  of  the 
following  four  files  will  cause  a  MICRO-COBOL  program  to  be 
compiled  and  executed: 

1.  COBOL.COM 

2.  PART2.COM 

3.  EIEC.COM 

4.  CINTERP.COM 

These  four  files  are  created  from  the  following  six 
PLM80  source  programs. 

1 .  PARTI .PLM 

2.  PART2.PLM 

3.  BUILD. PLM 

4.  READER. PLM 

5.  INTRDR.PLM 

6.  INTERP.PLM 


The  procedures  used  to  create  the  four  object  files  (COM 
files)  involve  compiling,  linking,  and  locating  each  of  the 
six  source  files  under  ISIS.  The  SIC  program  is  then  used 
under  CP/M  to  construct  the  executable  files.  Each  of  the 
following  steps  describe  the  action(s)  to  be  taken  and, 
where  appropriate,  the  command  string  to  be  entered  into  the 
computer. 

1.  An  ISIS  system  disk  containing  the  PLM8e  compiler  is 
placed  into  drive  A  and  a  non-system  disk  containing  the 
source  programs  is  placed  into  drive  B.  It  should  be  noted 
that  drive  A  and  B  are  the  CP/M  reference  names  for  the 
drives  while  PI  and  F2  are  the  ISIS  reference  names  used  for 
the  associated  disk  drives. 

2.  Compile  the  PLM  source  program  under  ISIS  using  the 
the  following  command: 

PLM80  :F1  :<filename>.PLM  DEBUG  XREF 

DEBUG  saves  the  symbol  table  and  line  files  for  later 
use  during  debugging  sessions.  XREF  causes  a  cross-reference 
listing,  of  all  identifiers  in  the  source  program,  to  be 
created.  The  cross-reference  listing  includes  each 
identifier  and  the  associated  line  number  where  the 
identifier  was  declared  and  the  line  number  of  each 
occurence  of  the  identifier  in  the  source  program  [12). 

3.  Lick  the  PLM80  object  file. 
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LINE  :Fl:<f ilename>.OBJ,  TRINT.OBJ,  PLM80.LIP,  TO 
:F1  :<f  ilename>.MOD 

See  reference  11  for  an  explanation  of  PLM83.LIB.  The 
TRINT.OBJ  program  Interfaces  the  MON1  and  M0N2  functions  of 
CP/M  to  the  source  program,  allowing  for  the  use  of  absolute 
addresses  in  referencing  these  functions. 

4.  Locate  the  object  file. 

LOCATE  :Fl:<filename>.MOD  CODE(org  address) 

The  "org  address"  is  the  address  where  the  prograr  will 
begin  to  be  loaded  into  memory.  The  following  are  ’’org 
addresses"  for  the  associated  program: 

PARTI. MOD  103H 
PART2.M0D  103H 
INTERP.MOD  103H 
INTRDR  .MOD  80B 
BUILD. MOD  103H 
READER. MOD  0B000R 

The  "org  addresses"  above  represent  the  ones  used  with  a  62K 
byte  CP/M  system.  The  only  address  that  would  need  to  be 
changed  if  a  different  size  system  was  used  would  be  the  one 
for  IREADER.MOD.  See  appendix  E  for  specifics  on  the  address 
to  use  for  IREADER. 

4a.  The  two  files  INTRDR  and  IREADF?  Just  created  by  the 


LOCATE  command  must  be  converted  to  "HEX  FILES".  By  using 
the  ISIS  command  OBJHSX  <filename>  the  file  will  be 
converted  to  the  "HEX  file"  <f ilename>.EEX. 

5.  Replace  the  ISIS  system  disk  in  drive  A  with  a  CP/M 
system  disk  and  reboot  the  system. 

6.  Transfer  the  located  ISIS  file  from  the  ISIS  disk  on 
drive  B  to  the  CP/M  disk  on  drive  A. 

FROMISIS  <fllename> 

6a.  When  transfering  the  "HEX  files"  to  the  CP/M  disk 
use  the  following: 

FROMISIS  <fllename>.HEX 

7.  Convert  the  ISIS  file  to  a  CP/M  executable  form. 

OBJCPM  <filename> 

7a.  The  "HEX  files"  are  not  coverted  to  a  CP/M  format, 
but  are  left  In  HEX  format. 

7b.  The  file  INTERP  should  be  renamed  to  CINTEBP  using 
the  command  "REN  CINTERP=INTERP"  before  the  file  is 
converted  to  CP/M  executable  form.  This  is  nessacary  because 
the  ISIS  operating  system  allows  file  names  to  be  only  six 
letters  in  length.  When  EXEC.COM  is  executed,  the  message 
"CINTERP.COM  NOT  FOUND"  will  be  displayed  if  this  step  is 
not  omitted. 

At  this  point  the  object  file  is  in  machine  readable 


form  and  will  run  under  CP/M  when  called  properly.  PART2.COM 
and  CINTERP.COM  are  called  by  PAR71.COM  (COBOI.COM)  and 
BUILD.COM  (EXEC.COM),  respectively  and  need  no  further  work. 
COBOL.COM  and  EXEC.COM  need  to  he  constructed  from  the 
remaining  four  files. 

COBOL.COM  is  created  by  entering  the  following  commands: 

1.  SID  PART1.COM 

2.  IREADER .HEX 

3.  R8600 

4.  A314A 

5.  JMP  0B000 

6.  Control-C 

7.  Save  56  COBOL.COM 

See  reference  7  for  an  explanation  of  the  "i",  ”r",  anl 
"a”  commands  used  above  and  ref  5  for  an  explanation  of  the 
"SAVE"  command.  Steps  four  and  five  above  are  used  to  patch 
the  JUMP  to  READER  referred  to  in  the  PARTI. PLM  program  into 
the  PART1.COM  program.  It  should  be  noted  that  each  time 
PART  ONE  is  changed  and  recompiled  the  address  of  the 
"patch"  instruction  (step  4  above)  will  change.  Use  of  the  L 
command  will  aid  in  locating  the  address  that  needs  to  be 
changed.  The  assembly  language  code  will  have  the  following 
form:  314A  JMP  314A. 

EXEC.COM  is  created  by  entering  the  following  commands: 
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1.  SID  BUILD. COM 

2.  IINTRDR.HEX 

3.  R1C00 


4.  CONTROL-C 

5.  SAVE  31  EXEC.COM 

NPS  MICRO-COBOL  programs  may  now  be  executed  In  the 
following  manner.  The  source  program  Is  named, 

<fllename>.CBL.  The  command  "COBOL  <fllename>”,  causes  the 
MICRO-COBOL  source  program  to  be  read  into  memory  and 
compiled.  During  the  compilation,  the  intermediate  code 
file,  <f ilename>.CIM ,  is  written  out  to  the  disk  as  the  code 
is  generated.  The  command  "EXEC  <filename>”,  causes  the 
file,  <f ilename>.CIN,  to  be  executed. 


APPENDIX  D 


PART  ONE  AND  PART  TWO  INTERNAL  DATA  STRUCTURES 
AND  SIGNIFICANT  VARIABLES 

Within  PART  ONE  and  PART  TWO,  many  significant  data 
structures  are  used  by  the  procedures  which  constitute  tne 
scanner  and  parser.  Descriptions  are  given  below  for  those 
structures  regarded  as  important  and  necessary  for  future 
compiler  development. 

1.  Interfacing  Structures 

ADD$END  —  this  variable  is  used  to  hold  the  end  cf  file 
filler  for  the  end  of  the  source  program. 

BUFFER (11 )  —  byte  array  used  to  hold  the  filename  and 

filetype  if  declared,  of  an  input  or  output'  file  in  the 
SELECT  CLAUSE  of  the  FILE  SECTION  of  a  KICRO-COBOL  source 
program. 

BUFFER$END  —  address  variable  which  marks  the  last  byte 
of  the  compiler  input  buffer  which  is  a  128  byte  buffer  used 
for  reading  the  source  program. 

ERROR$CTR (5 )  —  byte  array  used  to  hold  a  count  of  the 
total  number  of  errors. 

IN$ADDR  —  address  variable,  default  file  control  block 
used  initially  to  hold  the  <f ilename.CBL>  of  the  source 
program  to  be  compiled. 

IN$BUFF  —  literal  value,  marks  the  first  byte  of  the 


compiler  input  buffer 


INPUT$FCB  —  byte  value,  based  at  IN$ADDR(33),  the  base 
address  of  the  default  file  control  block  of  the  source 
program. 

LINE$CTR  —  byte  value  that  keeps  track  of  the  number  of 
lines  in  the  input  file.  Also  used  to  write  the  line  cumbers 
to  the  list  file. 

LIST$BUF?(128)  —  byte  array,  used  as  a  128  byte  output 
buffer  for  loading  the  generated  list  file. 

LIST$FCB(33)  —  byte  array  for  the  list  file,  file 
control  block. 

LIST$PTR  —  address  value,  used  as  an  index  into  tne 
list  buffer  (LIST$BUFF) . 

OUTPUT$BUFF ( 128 )  ~  byte  array,  used  as  a  128  byte 
output  buffer  for  loading  the  generated  output  (pseudo 
instructions)  when  writing  to  the  intermediate  code  file. 

OUTPUT$CHAR  —  byte  value,  based  at  the  OUTPUT$PTR?  used 
to  identify  the  particular  byte  of  the  output  buffer 
(OUTPUT$BUFF)  to  which  the  next  intermediate  code 
instruction  is  to  be  written. 

OUTPUT$END  —  address  variable,  pointer  to  the  end  of 
the  output  buffer  (OUTPUT $EUFF) . 

0UTPUT$FCB(33)  —  byte  array,  the  FCB  for  the 
intermediate  code  file  <f ilename ,CIN>  established  in  PART 
ONE  of  the  compiler  and  pasted  to  PART  TWO  of  the  compiler 
by  IREAEER  module. 
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OUTPCT$PTR  —  address  value,  used  as  an  Index  Into  the 
output  buffer  (OUTPCT$BUEE) . 

POINTER  —  address  value,  the  address  of  the  byte 
holding  the  next  Input  character  of  the  source  program. 

2.  Debugging  Structures 

DEBUGGING  —  logical  byte  value,  toggle  used  In 
conjunction  with  In  a  MICRO-COBOL  source  program  text; 
allows  for  the  compilation  or  non-compllatlon  of  the 
deugglng  statements  following  the 

ERROR  —  logical  byte  value,  toggle  used  to  Indicate  an 
error  condition  and  override  a  nollst  condition  thus 
allowing  errors  to  be  written  to  the  list  file  reguardless 
of  the  wrlte$lst  toggle. 

LIST$INPUT  —  logical  byte  value,  toggle  used  to  display 
or  not  display  a  source  program  to  the  CRT  during 
compilation. 

NO$CODE  —  logical  byte  value,  toggle  used  to  stop  code 
generation  for  faster  syntax  checking. 

PARMLIST (9)  —  byte  array  used  to  hold  the  toggles  set 
by  the  compiler  developer  or  user  upon  execution  of  the 
command:  COBOL  <f ilename.CBL>  ^TOGGLES. 

PRINT$PROD  —  logical  byte  value,  toggle  used  to  print. 
In  chronological  order,  at  the  CRT  the  production  numbers  of 
the  compiler  grammar  rules  used  during  a  compilation  of  the 


source  program 


PHINT$TOIEN  —  logical  byte  value,  toggle  used  to  print 
tokens  and  the  numbers  assigned  to  them. 

SEQ$N0M  —  logical  byte  value,  toggle  used  to  indicate 
the  presence  of  sequence  numbers  in  the  first  six  positions 
of  each  line  of  a  source  program  being  compiled. 

WRITE$LST  —  logical  byte  value,  toggle  used  to  indicate 
whether  a  list  file  is  to  be  generated.  A  limited  list  file 
containing  errors  and  the  line  being  parsed  at  the  time  of 
the  error(s)  is  always  created. 

UE$FLAG  —  logical  byte  value,  toggle  used  to  indicate 
whether  there  is  an  undeclared  varible. 

3.  Memory  Structures 

FOFFILLER  —  literal  value,  used  to  test  for  the 
occurrence  of  an  end  of  file  character  ("lAH"  in  CP/M),  when 
reading  the  source  program. 

FREESSTORAGE  —  first  free  address  following  PART  ONE  of 
the  compiler;  utilized  as  the  base  of  the  symbol  table.  This 
is  the  same  value  as  HASH$TAB$ADDR  in  PART  TWO  of  the 
compiler. 

INITIAL$POS  —  address  value,  the  initial  location  of 
the  IREADER  module  before  it  is  copied  to  high  memory  at 
location  MAX$MEMORT. 

MAX$MEMORT  —  address  value,  the  location  in  high  memory 
where  the  IREADFR  module  is  to  be  moved. 

MAX$INT$MEM  —  address  value,  the  highest  usable 


addressable  memory.  This  Is  the  point  where  no  more  code  can 
be  generated  due  to  insufficient  memory. 

NEXT$ AVAILABLE  —  address  value,  the  pseudo  machine 
memory  address  for  the  next  machine  instruction. 

PART1$LEN  —  the  number  of  bytes  of  information  saved  in 
high  memory  after  execution  of  PAST  ONE  and  used  to 
initialize  PART  TVO  module  variables  of  the  compiler. 

PASS  1$ TOP  —  this  address  is  used  in  conjunction  with 
PASS1$LEN  for  locating  the  fourty-eight  bytes  of  information 
saved  in  PART  ONE  for  use  in  PART  TWO  of  the  compiler. 

RDR$LENGTH  —  literal  value  representing  the  255  bytes 
of  the  IREADER  module  to  be  moved  from  INITIAL$POS  to 
KAX$*EKORT. 

4.  Scanner  Structures: 

ACCUM(51)  —  an  array  of  51  bytes;  the  first  byte 
contains  a  count  of  the  total  number  of  characters  currently 
in  the  accumulator.  This  structure  holds  tokens  as  they  are 
scanned,  and  will  hold  either  a  reserved  word,  a  user 
defined  identifier,  or  a  literal. 

COLLISION  —  address  varible,  contained  in  first  two 
bytes  of  an  identifier's  symbol  table  entry  and  indicates 
whether  there  is  another  identifier  which  hashes  to  the  same 
hash  table  address.  This  address  points  to  that  identifier's 
address  in  the  symbol  table. 

DISPLAY (88)  —  an  array  of  74  bytes?  the  first  byte 


contains  a  count  of  the  total  number  of  characters  (l-?3) 
currently  in  the  display  buffer.  Every  line  within  a  source 
program  is  loaded  into  this  structure  for  subsequent 
printing  to  the  CRT  terminal  during  compilation. 

EDIT&ELAG  —  logical  flag  which  denotes  the  fact  that  a 
symbol  has  been  loaded  into  the  DISPLAY  array  durine 
compilation.  Vhen  set  the  characters  within  DISPLAY  will  be 
printed  one  at  a  time,  until  the  entire  line  is  printed. 

HASHiTABLE$ADDR  —  the  base  of  the  symbol  table 
generated  in  PART  ONE,  used  as  the  base  of  the  hashtable. 

HASH$TAB$ADDR  —  this  was  the  address  of  the  bottom  of 
the  symbol  table  generated  in  PART  ONE  of  the  compiler,  and 
saved  for  Part  two. 

INPOT$STR  —  literal  value  (32),  returned  to  the  LALR(l) 
parser  anytime  the  token  contained  in  the  ACCUK  is  not  a 
reserved  word  or  literal. 

LITERAL  —  literal  value  (15),  returned  to  the  LALR(l) 
parser  anytime  the  first  character  encountered  by  the 
scanner  is  a  quote  ('),  prior  to  loading  the  ACCUK. 

KAX$LEN  —  length  of  the  longest  reserved  word  allowed 
by  MICRO-COBOL. 

5.  Parser  Structures: 

BUTTER (31)  —  byte  array  used  to  store  edited  PICTURE 
CLAUSE  characters  for  subsequent  intermediated  code 
generation. 


COMPILING  —  logical  byte  value  which  indicates  that 
compiling  is  talcing  place  or  not  in  PART  OUT  or  PART  TWO? 
set  to  FALSE  whenever  the  statestack  cf  the  LALP.(l)  parser 
is  reduced  to  a  recognizable  finished  state* 

COR$STM  —  address  variable  that  holds  the  address  of 
the  current  symbol  being  accessed  in  the  symbol  table. 

DUP$IDFN$ARRAT (24)  —  address  array  that  holds  the 
symbol  address  for  all  files  declared  in  the  INPUT-OUTPCT 
SECTION  of  a  source  program.  When  the  FILE  SECTION  entry  for 
the  file  is  encountered  the  array  is  searched  to  determine 
if  the  file  was  declared  and  to  insure  that  a  FILE  SECTION 
entry  had  not  been  previously  made. 

FILE$DESC$FLAG  —  logical  byte  value?  indicates  whether 
the  compiler  is  compiling  the  FILE  INSCRIPTION  SECTION  of  a 
source  program  or  not. 

FILE$S£C$END  —logical  byte  value  set  whenever  the 
parser  has  parsed  passed  the  FILE  SECTION  of  a  source 
program. 

H0LD$LIT(51)  —  byte  array,  first  byte  contains  a  count 
of  the  total  number  of  characters  currently  stored  in  the 
BOLDLIT  buffer  which  is  used  to  hold  characters  for  a  VALLE 
CLAUSE. 

IB$STACK( 10 )  —  address  array  which  functions  as  a  stack 
and  is  used  to  hold  the  addresses  of  Identifiers  at  both  the 
record  and  elementary  levels.  Whenever  a  record  Identifier 
has  nested  elementary  field  identifiers  it  is  saved  on  the 


ID$STACK.  Also,  anytime  a  record  identifier  has  succeeding 
record  identifiers  redefining  it.  it  is  saved  on  the 
IDSSTACX.  In  the  case  of  multiple  record  descriptions  in  a 
file  description  of  the  FILE  SECTION,  the  record 
descriptions  following  the  first  record  are  assumed 
redefinitions . 

ID$$TACK$PTR  —  a  byte  index  variable  into  the  ID$STACK 
array. 

MAX$ID$LEN  —  a  numeric  value  (12),  maximum  length  of 
any  user  defined  identifier. 

MP  —  byte  index  variable  into  the  VALUE  array. 

MPPl  —  byte  index  variable  into  the  VALUE  array,  one 
byte  above  M?  index. 

NEXT$SYM  —  this  address  indicates  the  next  available 
free  space  for  a  symbol  table  entry. 

PENDINCHITERAL  —  byte  value  (0 ,1 ,2 ,3,4, 5) ,  indicates 
the  category  of  the  target  input  to  a  VALUE  CLAUSE. 

PENDING$LIT$ID  —  byte  value  (0 ,1 ,2 ,3 ,4, 5) ,  which  is 
saved  to  indicate  the  category  of  the  most  recently 
encountered  target  input  to  a  VALUE  CLAUSE. 

PRODUCTION  —  byte  value,  determined  by  the  parser  and 
indicates  the  next  semantic  action  to  be  taken  by  the 
compiler. 

REDFF  —  logical  byte  value  which  allows  the  testing  of 
an  identifier's  storage  value  size  against  the  storage  value 
size  of  a  second  identifier  that  redefines  the  first.  Set  to 
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TRUE  when  there  are  multiple  record  descriptions  within  a  FD 
BLOCK  in  the  FILE  SECTION,  or  when  a  record  or  elementary 
identifier  declaration  in  the  WORKING  STORAGE  SECTION 
contains  a  REDEFINES  CLAUSE. 

REDEF$FLAG  —  logical  byte  value,  used  to  denote  the 
scanning  and  parsing  of  the  FILE  SECTION  of  a  source 
program,  helps  in  identifying  duplicate  identifiers  within 
this  section. 

REDEF$ONE  —  address  variable  that  holds  the  symbol 
table  address  of  the  identifier  being  redefined  by  another 
identifier . 

REDEF$TWO  —  an  address  variable  that  contains  the 
symbol  table  address  of  an  identifier  which  redefines 
another  identifier. 

SP  —  a  byte  index  for  the  STATESTACK  array  and  the 
VALUE  array*  points  to  the  top  of  the  STATESTACK  array. 

STATE  —  a  byte  value  numeric  quantity  that  indicates 
the  current  parser  state. 

STATESTACK(48 )  —  a  byte  array  which  stacks  the  states 
(production  sequences)  the  parser  passes  through  while 
compiling  a  source  program. 

TRUNCSFLAG  —  logical  byte  value  that  indicates  numeric 
truncation  of  an  identifier's  VALUE  CLAUSE  input  hasn't 
occurred,  because  the  identifier's  associated  PICTURE  CLAUSE 
has  not  been  scanned  and  parsed. 

VALUE(40)  —  an  address  array  that  holds  addresses  of 
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identifiers,  specific  attributes  of  these  identifiers  and 
attributes  of  the  current  source  program  statement  or 
sentence  being  parsed. 

VARC(51)  —  a  byte  array,  the  first  byte  holds  the  count 
of  the  total  number  of  characters  within  it,  used  to  hold 
all  the  ASCII  characters  of  tokens  scanned  within  the  source 
program,  excluding  reserved  words?  for  subsequent  analysis 
and  processing. 

VALUE$FLAG  —  a  logical  byte  that  is  set  anytime  an 
identifier  has  an  associated  VALUE  CLAUSE;  used  primarily  to 
recognize  the  occurrence  of  a  PICTURE  CLAUSE  before  the 
VALUE  CLAUSE  or  when  a  record  entry  has  a  VALUE  CLAUSE,  but 
no  associated  PICTURE  CLAUSE  except  for  those  in  its 
elementary  field  identifiers. 

VALUED  LEV EL  —  a  byte  value  which  saves  the  level  number 
of  a  record  identifier  which  doesn't  have  an  associated 
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MACHINE  DEPENDENT  VARIABLES 

The  NPS  MICRO-COBOL  compiler/interpreter  is  designed  to 
operate  on  any  8063  or  Z83  based  microcomputer  operating 
under  CP/M  with  at  least  20K  bytes  of  memory.  The  PLM80 
source  files  have  been  written  in  such  a  way,  that  certain 
variables  must  be  altered  in  the  source  code  to  take 
advantage  of  the  machine  that  the  programs  are  going  to  be 
operating  on.  This  appendix  covers  those  programs  and  the 
variables  that  must  be  altered. 

1.  PARTI. PLM 

This  program  has  two  variables  that  are  memory  site 
dependent,  MAXiMEMORY  and  MAX$INT$MEMORY.  The  variable 
MAX$MEMORT  is  set  to  100H  bytes  below  the  base  of  the  BDOS 
and  is  used  for  the  beginning  address  of  the  IREADER 
routine.  The  variable  MAX$INT$MEMORT  is  set  to  the  base 
address  of  the  BDOS  and  is  used  as  the  upper  limit  for  the 
intermediate  code  file. 

2.  PART2.PLM 

This  program  also  has  two  variables  that  are  memory  size 
dependent,  MAX$MEMORY  and  PASS1$T0P.  In  this  program 
MAX$MEMORT  is  set  to  the  base  address  of  the  BDOS  while 
PASS1$T0P  Is  set  to  100H  bytes  below  the  base  of  the  BDOS. 

3.  READER  .PLM 

Although,  this  program  does  cot  have  any  memory  size 
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dependent  variables  the  program  rust  be  modified  to  execute 
properly.  When  using  the  LOCATE  command,  under  ISIS,  this 
routine  must  be  located  122H  bytes  below  the  BDOS  of  the 
system.  This  address  would  correspond  to  the  values  of 
MAXiMEMORT  in  PART2.PLM  and  MAX$INT$MEMORT  in  PARTI. PLM. 

4.  BUILD. PLM 

This  program  has  one  memory  size  dependent  variable, 
I NT£RP$ ADDRESS  must  be  set  to  the  same  address  as  COBE$START 
in  INTERP.PLM. 

5.  INTERP.PLM  and  INTRDR.PLM 

These  two  programs  have  no  variables  that  need  to  be 
altered . 

6.  GENERAL  INFORMATION 

The  current  version  of  the  NPS  MICRO-COBOL 
compiler/interpreter  is  designed  for  continued  development 
and  certain  variables  are  not  set  to  make  optimal  use  of 
memory.  The  variable  NEXT$AVAILABLE,  in  PARTI. PL*,  is  set  to 
3502H  and  CODE$STAFT,  in  INTERP.PLM,  is  set  to  3500H. 
Normally,  CCDE$START  would  be  set  to  the  address  immediately 
following  the  last  address  in  CINTERP.COM  and  NEXTSAVAlLABLE 
would  be  set  two  bytes  above  that  address.  These  address  are 
currently  set  approximately  450H  bytes  above  where  they 
should  be  located,  to  allow  for  testing  and  expansion  of  the 
Interpreter.  As  soon  as  Implementation  is  completed  these 
two  addresses  can  be  reset  to  appropriate  values. 
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MICRO-COBOL  PARSE  TABLE  GENERATION 

The  parse  tables  for  NPS  Micro-Cobol  were  generated  on 
the  IBM  360  using  the  LALR(l)  parse  table  generater 
described  in  reference  20.  There  are  basically  two  steps 
involved  in  generating  the  tables.  First,  a  deck  of  cards 
containing  the  grammar  is  entered  into  the  computer  using 
the  following  JCL: 

//PROGNAME  JOB  (2320.0417.CS91 ), 'optional  data',TIME=5 
//GO  EXEC  PGM=  LALR , REGION  =220K 
//STEPLIB  DD  DS N=F0 11 9. LALR .UN  IT-2314 . 

VOL=SER=LINDA ,DISP=SHR 
//SYSPRINT  DD  SYSOUT=A,DCB=(RECFM=F3 . 

LRECLS133 ,BLKS IZE-3325 )  , 

//  SPACE=(CYL.<1,1)) 

//NCNTEPM  DD  SPACE=(CYL,(1,1)),UNIT=SYSDA 
//FSMDATA  DD  SPACE=(CYL, (1 ,1 ) ) ,UNIT=SYSDA 
*  //PTABLES  DD  SYSOUT=B, 

DCB=(RECFM=FB,LRECL*80,BLKSIZE=800) 

//SYS IN  DD  * 

*  This  card  can  be  replaced  by  //PTABLES  DD  SYSOUT=DUMMY 
to  surpress  the  card  punching  feature.  This  allows 
modifications  to  be  made  without  wasting  cards  until 
a  new  LALR(l)  grammer  is  produced. 


177 


The  ouput  from  this  run  is  a  listing  and  a  card  deck 
containing  the  tables  in  XPL  compatable  format.  This  deck  is 
then  translated  into  PLM  compatible  format  using  the 
following  JCL  and  an  XPL  program  which  is  available  in  the 
card  deck  library  in  the  Computer  Science  Department  at  the 
Naval  Postgraduate  School. 

//EXEC  XCOM 
//COMP. STS  IN  DD  * 

//GO.STSPUNCH  DD  STS0UT=B, 

DCB*!(RECFM=FB,LRECL=80  ,BLKSIZEa800) 

//GO.STSIN  DD  * 

The  tables  are  then  transferred  to  a  diskette  and  edited 
into  the  PLM80  source  program  using  the  ISIS  COPT  and  EDIT 
features  on  the  INTEL  MDS  System.  See  APPENDIX  H  for  the 
procedures  to  transfer  files  from  the  IBM-360  to  a  floppy 
diskette . 
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LIST  01  INOPERATIVE  CONSTRUCTS 

The  following  Is  a  list  of  MICRO-COBOL  elements  that 
either  have  not  been  implemented. 

CLOSE  -  multiple  closes 

OPEN  -  multiple  open's 

The  following  HTPO-COBOL  elements  are  part  of  NPS 
MICRO-COBOL  only  to  the  extent  that  they  are  defined  in  the 
grammar.  No  code  has  been  written  to  support  them. 

COMPUTE 

AND  and  OR 

ENTER 

COMP  and  COMPUTATIONAL  (binary  arithmetic  storage  and 
operations) 

INDEXED 

MULT I -DIMENSION  tables 


APPENDIX  H 


IBM  TO  MICROCOMPUTER  TRANSFER  PROCEDURES 

A  CP/M  operating  system  program  was  written  by  Prof. 
Kodres  for  the  express  purpose  of  transferring  ASCII  files 
from  the  IBM  CP/CMS  system.  In  order  to  use  this  program, 
several  equipment  requirements  must  be  ret:  a.)  Reserve  the 
appropriate  Intel  MDS  system  in  the  Microcomputer  Lab.  b.) 
Call  646-2721 (computer-center)  to  reserve  a  high  speed(12e0 
baud)  line  to  the  micro-lab.  c.)  Connect  the  line  marked 
"IBM  1200  BAUD"  line  to  the  "black  box"  marked  IBM,  which 
contains  line  drivers  for  the  RS-232  circuit.  Check  that  the 
toggle  switch  is  in  the  up/raised  position,  d.)  Connect  the 
serial  connector  coming  oft  the  MODIFIED  single  board 
computer  (marked  with  a  yellow  dot)  to  the  other  end  of  the 
line  driver  box.  All  of  the  other  boards  in  the  MDS  are 
unmodified  with  the  exception  of  times  when  hardware 
experimentation  is  being  conducted  by  various  groups  of 
students  and/or  facalty. 

To  commence  communication  with  the  360  -  invoke  the  CP/M 
program  IBM.COM  -  an  executible  file.  The  program  is  loaded 
and  executed  by  typing  "IBM  filename. filetype",  where 
"filename. filetype"  is  selected  by  the  user  as  the  CP/M  file 
which  will  be  created  as  a  result  of  a  file  transfer. 
Successful  completion  of  the  above  steps  will  result  ir.  the 
following  data  being  displayed  on  the  CRT: 


1 


(crt  echo?  y/n)  Answer  "y” 

(n)  Placed  by  the  CP/M  program 

Enter  a  <CR> 

caCP-67  Online  Normal  CP/CMS  signon  message 

At  this  point  login  to  CP/CMS  in  a  normal  manner.  Files 
are  transfered  using  the  CMS  command  "PRINT"  followed  by  the 
name  of  the  file  to  be  transfered  followed  by  a  control-R. 
This  will  cause  the  MDS  to  be  put  into  the  receive  mode.  A 
<CR>  will  start  the  file  transfer.  The  CRT  should  display 
the  following  for  a  successful  file  transfer. 

PRINT  cmsfilename  cmsfiletype  Enter  a  control-R 

(R)  Puts  MDS  in  receive  mode 

(R.  CREATED  filename. filetype)  Enter  a  <CR> 

( -  bytes  received  END  R)  Enter  a  <CR>  to  re-enter  CP 

Enter  a  control-C  to  reboot 

Each  file  transfer  must  be  done  with  a  separate 
invocation  of  the  IBM  file  as  all  files  will  be  transfered 
to  the  file  named  when  IBM  is  invoiced.  Before  rebooting  for 
the  last  time  logout  of  CP/CMS  in  the  normal  manner  and  call 
2721  and  inform  the  computer  center  that  the  high  speed  line 
is  available  for  other  user's. 
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DEBUGGING  NPS  MICRO-COBOL  USING  SID 

Note:  Steps  two  and  three  are  optional.  They  are  used  If 
the  line  numbers  In  the  program  listing  are  to  be 
used  as  well  as  the  symbols  for  pass  points. 

PART  ONE. 

1.  SID  C030L.C0M  PARTI. STM 

2.  I*  PARTI. LIN 

3.  R  <ret> 

4.  I<file  name.C3L>  $<complller  toggles  as  required> 

5.  Set  desired  passpolnts 

PART  TWO. 

1.  SID  COBOL.COM  PART2.STM 

2.  I*  PART2.LIN 
?.  F<ret> 

4.  Kfile  name.CBL>  $<compiller  toggles  as  requlred> 

5.  T50 

6.  G.0B000 

7.  T50 

8.  Gt100 

9.  Set  desired  passpolnts 


INTERPRETER.  Note:  Use  only  STM  or  LIN  files  but  not  both. 

1.  SID  EXEC.COM  CINTERP.STM 

2.  I*  CINTERP.LIN 

3.  R<ret> 

4.  I<f lie  name.CIN> 

5.  G  ,22E 

6.  T25 

7.  G  ,100 

8.  Set  desired  passpolnts 

These  Instructions  are  designed  to  get  the  programs  to  the 
proper  place  to  be  able  to  use  SID.  See  reference  [8]  for 
Instructions  on  how  to  use  SID  commands.  It  should  be  noted 
that  changes  to  the  routine  BUILD  will  change  Instruction  5 
in  the  INTERPRETER  command  list.  That  command  is  Intended  to 
stop  after  BUILD  has  finished  executing  and  Is  the  location 
of  the  last  instruction  In  that  module. 
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COMPUTER  LISTING  TOR  MODULE  PART  ONE  NPS  MICRO-C0R0L 

$  TITLE('NPS  MICRO-COBOL  COMPILER  PARTI')  PAGEVIDTB( 80 ) 
PAGELENGTB (60) 

PARTI sDO? 

/*  COBOL  COMPILER  -  PART  1  */ 

/*  NORMALLY  LOCATED  AT  103H  */ 

/*  GLOBAL  DECLARATIONS  AND  LITERALS  V 

DECLARE  DCL  LITERALLY  'DECLARE', 

LIT  LITERALLY  'LITERALLY' » 


CR 

LIT 

'13', 

EOEEILLER 

LIT 

'1AH' ,  /*  END  OF 

RECORD  FILLER 

PALSE 

LIT 

'0' , 

ERROR 

BYTE 

INITIAL (FALSE ) , 

FILE$DESC$FLAG  BYTE 

INITIAL(FALSE), 

0I$7LAG 

BYTE, 

/♦UNDECLARED  VAR 

FLAG*/ 

FOREVER 

LIT 

'WHILE  TRUE', 

INITIAL$POS 

ADDRESS 

INITIAL(3600H), 

LF 

LIT 

'10'. 

MAX$MEMORY 

ADDRESS 

I NI TIAL ( 0B000E ) , 

QUOTE 

LIT 

'27H ' , 

PARMLIST(9) 

BYTE 

I NITIAL( ' 

')• 

PARMS 

LIT 

'6DH' , 

PASS1SLEN 

ADDRESS 

INITIAL(353 ) , 

POUND 

LIT 

'23H', 

PROC 

LIT 

'PROCEDURE', 

RDR$LENGTH 

LIT 

'255', 

TRUE 

LIT 

'l'; 

MAXLNO 

LITERALLY 

'138',  /*  MAX  LOOK  COUNT  */ 

MAXPNO 

LITERALLY 

'156',  /*  MAI  PUSH  COUNT  V 

MAXRNO 

LITERALLY 

'110',  /*  MAX  READ  COUNT  */ 

MAXSNO 

LITERALLY 

'253',  /*  MAX  STATE 

COUNT  */ 

STARTS 

LITERALLY 

'1' 

,  /*  START  STATE  */ 

PRODNO 

LITERALLY 

'97 

',  /*  NUMBER  OF 

PRODUCTIONS  */ 

PROCC 

LITERALLY 

'48 

',  /*  PROCEDURE 

*/ 

TERMNO 

LITERALLY 

'64 

;  /*  TERMINAL  COUNT  */ 

DCL  READ1  (*)  BYTE 

DATA{ 0,61 ,50 ,60, 33, 8, 25, 63, 2, 33, 55, 62, 11, 33, 33, 41, 40, 36 
,46,9,19,39,6,26,34,59,3,14,15 ,18,20,33,29,51 ,33,1,44,40 
,38,45,1,1,1,1,1,1,1,1,1 ,10,1  ,41,1,1,1,40,1,35,42,51.40 
,41 , 1 , 1 ,40, 16, 17, 22 ,30, 23, 24 ,58, 54 ,57 ,43,37,48 ,1 ,7 ,52 ,1 
,33,1,33,33,47,1,33,1,33,1,33,1,33,49,27,33,39,4,35,56 
,42, 1,1, 33, 5, 12, 13, 21, 22, 28, 1,64, 1,23,24, 58, 31, 53); 
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DCt  tOOSl(*)  BYTE 

DATA (0 ,8,0,25,0,9, 19,0,44, 0,44 ,0,1 ,0,54,0 ,57,0,43,0,37,0 
,52,0,1,0,49,0,4,0,35,0,56,0,42,0,1 ,0,2,0,33,0,1,0,1,0,11 
,0,64,0,7,0,33,0,33,0,33,0); 

DCt  A FPLY1 (* )  BYTE 

DATA( 0,0, 0,0, 0,0, 0,0, 9, 10, 12, 14, 16, 20, 0,0, 0,0, 0.0, 107, 0,0 
,106  ,0,0 ,0,0 ,0,0, 103, 0,28, 0,0 •0,0,98,0,0,0,96,0,0,0,0,13 
,18,0,108,109,110,0,0,0,0,0,101,0,0,56,0,0,24.31,39,40,0 
,22,41 ,42,54,58,90,99,100,0) ; 

DCt  READ2  (*)  BYTE 

DATA (0,68, 59, 67, 168, 27, 38, 70, 22, 252, 63, 69, 28, 253, 231, 53 
,47,114,115,242,243,45,232,233,235,234,23,249,248,251,250 
,247,189,188,184,9,245,49,212,211,7,8,11,13,15,2,3,111,16 
,173,4,52,21,14,19,50,12,187,186,185,46,51,20,10,48,31,32 
,34,40,36,37,66,62,65,55,44,157,17,26,60,112,169,160,169 
,169,57,162,169,164,169,166,169,172,169,58,224,253,209 
, 24, 42, 64, 54, 222, 196, 253, 25, 29, 113, 33, 35, 39, ie, 71, 179, 36 
,37,66  ,41,61); 

DCt  t00K2(*)  BYTE 

DATA (0,5,139,6,140,30,30,141,43,142,56,143,144,72,74.145 
, 75, 146, 76, 147, 77, 148, 81, 149, 150, e4, 89, 151, 92, 214, 93, 239 
,94,152,95,153,205,96,98,200,99,213,227,101,154,102,103 
,192,105,155,156,107,108,216,109,218,110,204); 

DCt  APPLY2(»)  BYTE 

DATA(0, 0,121, 158, 118, 117, 119, 159 ,83, 122, 85, 86, 87, 88, 82 ,80 
, 126, 79, 170, 135, 178, 177, 106, 181, ie0, 182, 127, 163, 175, 133 
,195,194,100,130,78,134,129,203,202.104,128,208,207,210 
,120„199, 137, 138, 136, 221, 221, 221, 220, 123, 132, 97, 131, 230 
,229,240,237,236,241,215,91,125,124,90,116,73,238,190,225 
,223,198.198,197); 

DCt  INDEXK*)  BYTE 

DATA (0,1, 2, 3, 4, 5, 6, 7, 8, 4, 4, 9, 4, 9, 4, 10, 4, 11, 9, 117  ,4,12,13 

,13,9,14,15,16,13,17,19,9,21,22,26,27.32,34,35,9,9,13,13 

,36,37.38,40,41,42,43,44,45,46,47,13,48,36,49,13,50,51 ,52 

,53,54,55,56,57,60,61,62,63,64,65,69,72,73,74,75,76,77,78 

,79,80,82,84,86,88,90,92,94,95,97,98,99,100,101,65,102,8 

,13,103,105,105,12,111,112,113,117,9,9,9,1,3,5,9,10,12 


,14,16,18,20,22,24,26,28,30,32,34,36,38,40,42,44.46.48,50 
,52,54,56 ,201,161,244,246,246,206,165,163,167,219,171,174 
,226,176,191,229,217,193,1,2,3,4,4,5,5,6,6,7,7.8,8,15.15 
,16,17,17,18,18,19,19,20,22,22,23,23,23,25,25,25,26,26,27 
,27,28,28,29,29,30,32,32,34,35,35,36,36,37.39,39,40.40,41 
,41,41,41 ,41 ,43,43,44,44,45,45,46,46,49,53,53,54,54,55,55 
,56,56,57,57,57,57,57,57,57,57,57,57,57,59,59,59,60,60,62 
,62,62.62,62,63,68); 

DCt  IHDEX2(*)  BYTE 

DATA (0,1, 1,1, 1,1, 1,1, 1,1, 1,1 ,1,1, 1,1, 1,1, 1,1, 1,1, 1,1,1 ,1 
.1,1, 1,2, 2, 1,1, 4, 1,5, 2, 1,1, 1,1, 1,1, 1,1, 2, 1,1, 1,1, 1,1. 1,1 
,1 ,1,1 ,1  ,1,1, 1,1, 1,1, 1,1, 3,1 ,1,1 ,1,1 ,4, 3,1, 1,1,1  ,1,1,1 ,1 
,2, 2, 2, 2, 2, 2, 2, 1,2, 1,1, 1,1, 1,4, 1,1, 1,2, 6, 6, 1,1, 1,4, 2, 1,1 


.1,2,2, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 
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,2,5,6,30  ,43, 56, ?2, 74, 75,76,77,81, 84, 89, 94, 95, 102, 105, 10? 
,3,7 ,3 ,3, 0,3, 0,3, 0,3, 0,0 ,1 ,7 ,0 ,8,1 ,0  ,6,0 ,0 ,1 ,3,0 ,1 ,1 ,2  ,1 
,0,0, 0,0, 0,1, 0,2, 0,0, 1,2, 0,1, 5, 3, 0,0, 1,4, 0,0, 0,1, 2, 1,2, 2 
, 2, 0,2, 3,0, 3,0,0, 1,4, 0,0, 1,0,0, 0,0, 1,1 ,1,1,1 ,1,2, 2, 3,1 ,1 

,1  ,0,0  ,0 ,@,0 ,0 ,0,0, 0,0, 0,0) f 

/*  JOINT  DECLARATIONS 

TEESE  ITEMS  ARE  DECLARED  TOGETHER  IN  THIS  SECTION 
IN  ORDER  TO  FACILITATE  THEIR  BEING  SAVED  FOR 
THE  SECOND  PART  OF  THE  COMPILER.  */ 


DEBUGGING 

BYTE 

INITIAL(FALSE), 

ERR0R$CTR(5 ) 

BYTE 

I NITI AL( '  0'), 

LINE$CTR(5) 

LIST$BUFF(128) 

LIST$FCB(33) 

,0), 

LIST$INPUT 

BYTE, 

BYTE, 

BYTE 

I N ITI AL(0 ,  ' 

BYTE 

INITIAL(TRUE), 

LISTSPTR 

ADDRESS, 

MAX $ I NTS MEM 

ADDRESS 

IN ITI AL ( 0B100 )  , 

NEXTSAVAILABLE 

ADDRESS 

IN ITIAL ( 3502H )  , 

NEXT$SYM 

ADDRESS , 

NO$CODE 

BYTE 

INITIAL(FALSE) , 

OUTPUTSBUFF ( 128 ) 
CUTPUT$FCB( 33 ) 
.0). 

OUTPUTS PTR 

BYTE, 

BYTE 

INITIAL(0,  * 

ADDRESS, 

POINTER 

ADDRESS 

INITIAL( 100B) , 

PRINTS PROD 

BYTE 

INITIAL(FALSE), 

PRINTSTOKEN 

BYTE 

INITIAL(FALSE), 

SEOSNUM 

BYTE 

INITIAL(FALSE), 

VRITESLST 

BYTE 

INITIAL(FALSE) , 

FREBSSTORAGE 

ADDRESS 

IN ITIAL(3800B) , 

FILESSECSEND 

BYTE 

IN ITI AL( FALSE) , 

LST', 0,0,0 


CIN', 0,0,0 


/*  I  0  BUFFERS 

IN$ADDR 

INPUTSFCB 

LISTSCHA* 

LISTSEND 

OUTPUT $CHAR 

OUTPUT$END 


AND  GLOBALS  V 
ADDRESS  INITIAL(5CH), 
BASED  IN$ADDR(33)  BITE, 
BASED  LISTSPTR  BITE, 
ADDRESS, 

BASED  OUTPUTSPTR  BITE, 

address; 


MON1:  PROC  (F,A)  EXTERNAL; 

DCL  A  ADDRESS,  F  BTTEJ 
END  MONi; 


M0N2:  PROC  (F,A)  BITE  EXTERNAL; 

DCL  F  BYTE,  A  ADDRESS; 

END  M0N2; 


BOOT:  PROC  EXTERNAL; 
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END  BOO?; 


PRINT$CEAR:  PROC  (CHAR); 

DCt  CHAR  BYTE? 

CALL  MON1  (2, CHAR); 

END  printchar; 

WRITES OUTPUT :  PROC (BUFF,FCB ) I  /*  WRITES  OUT  A  BUFFER  */ 

DCL  (BUFF.FCB)  ADDRESS? 

CALL  MON1 (26 ,BUEF) ;  /*  SET  DMA  */ 

IF  M0N2(21,FCB)  <>  0  THEN 
DO? 

CALL  M0N1(9,.('VR$')); 

CALL  boot; 

end; 

CALL  MON1(26,80E);  /*  RESET  DMA  */ 

END  writesoutput; 

WRITE$TO$DISK:  proc(char); 

DCL  char  byte; 

IF  (LIST$PTR  :=  LIST$PTR  +  1)  >  LlSTiEND  THEN 

do; 

CALL  WRITE$OUTPUT( .LIST$3UFF, .LlST$FCB); 
LIST$PTR  =  .LIST$BUFF; 

end; 

LISTSCHAR  *  CHAR; 

END  write$to$disk; 

PRINT:  PROC  (A); 

DCL  (A, ADDR)  ADDP ESS , CHAR  BASED  ADDR  BYTE? 

ADDR  -  A? 

DO  WHILE  CHAR  <> 

CALL  write$to$disk(chab); 

ADDR  *  ADDR  +  1J 

end; 

CALL  M0N1  (9,A); 

END  print; 

CRLF:PROC; 

CALL  M0N1(9,.(CR,LF, '$')); 

END  crlf; 

DCRLF:  PROC; 

CALL  write$tq$disk(cr); 

CALL  WRITE4T0$DISK(LF); 

END  DCRLF? 

INC$CTR:  PROC (BASE) ; 

DCL  BASE  ADDRESS,  CTR  BYTE,  BSBYTE  BASED  BASE  (1)  BYTE, 
TEN  LIT  '3AH'; 

CTR  ■  4; 
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DO  WHILE  (B$BYTE( CTR )  :=  B$BYTE( CTR )  +  1)  =  TEN; 
B$BYTE(CTR)  =  '0'j 
IE  CTR  >  0  THEN 

IF  B$BYTE (CTR  :=  CTR  -  1)  *  '  '  THEN 
B$BTTE(CTR)  *  '0'? 

end; 

END  INC$CTRJ 

PRINT$ERROR:  PROC  (CODE); 

DCL  I  BYTE, CODE  ADDRESS , CODE1 (6 )  ADDRESS; 

IE  CODE  *  FALSE  THEN 

do; 

DO  I  «  0  TO  5; 

CODEl(I)  *  a; 

end; 
i  =  0; 

end; 

ELSE  IF  CODE  =  TRUE  THEN 

do; 

I  **  0 ; 

DO  WHILE((I  <>  6)  AND  (  CODEl(I)  <>  0) ) 
CALL  PRINTCHAR(HIGH(CODEl(I)) ); 

CALL  PRINTCHAR(L0W  (CODEl(I)))5 
CALL  WRI TE$TO$ DISK (HIGH (CODE1 ( I ) ) ) ; 
CALL  WRITE$TO$DISK( LOW  (CODEl(I))); 
CALL  CRLFJ 
CALL  dcrlf; 

CODEl(I)  *  0; 

I  *  i  +  i; 

end; 
i  *  0; 

ERROR  «  FALSE; 

end; 

ELSE  IF  (CODE  »  'NP')  OR  (CODE  »  'SL') 

OR  (CODE  «  'NV')  THEN 

do; 

ERROR  »  TRUE? 

CALL  PR INTCHAR (HIGH (CODE  ) )  J 
CALL  PRINTCEAR(LOW (CODE) ) 5 
CALL  INC$CTR( .  ERROR $ CTR (0 ) ) ; 

IF  CODE  <>  'NP'  THEN 

do; 

CALL  crlf; 
call  dcrlf; 
end; 

end; 

ELSE 

do; 

ERROR  -  TRUE; 

IF  I  <>  6  THEN 


codei ( i )  »  code; 
i  *  i  ♦  i; 

end; 

CALL  INC$CTR( . ERROR $CTR(0  ) ) ; 

end; 

end  printserror; 

FATALSERROR:  PROC (REASON ) ; 

DCL  REASON  ADDRESS; 

CALL  PRINTSERROR (REASON ) 5 
CALL  PRINTSERROR(TRUE) ? 

CALL  boot; 

END  FATALSERROR V 

OPEN:  PROC; 

IP  M0N2  (15 , IN$ADDR )  =  255  THEN  CALL  FA TAL$ ERROR ( 'OP' ) 
END  open; 

MORE$ IN PUT :  PROC  BYTE; 

DCL  DCNT  BYTE; 

IP  (DCNT  :*  MON2(20, .INPUT$FCB) )  >  1  THEN 
CALL  PATAL$ERROR( 'BR'); 

RETURN  NOT(DCNT); 

END  MORES  INPUT ,* 

MAKE:  PROC(FCB); 

DCL  PCB  address; 

/*  DELETES  ANY  EXISTING  COPY  OP  THE  OUTPUT  PILE 
AND  CREATES  A  NEW  COPY*/ 

CALL  MON1 (1 9,  FCB ) J 

IF  M0N2(22.PCB)  *  255  THEN  CALL  FATALSERROR  (  >A ') ; 

END  make; 

MOPE:  PROC (SOURCE,  DESTINATION,  COUNT); 

DCL  (SOURCE, DESTINATION, COUNT)  ADDRESS, 

(SSBYTE  BASED  SOURCE,  DSBYTE  BASED  DESTINATION)  BYTE; 
DO  WHILE  (COUNT  :=  COUNT  -1)0  0FFFFHJ 
DSBYTE  -  SSBYTEJ 
SOURCE  =  SOURCE  +  1? 

DESTINATION  *  DESTINATION  ♦  1 J 

end; 
end  move; 

PILL:  PROC(ADDR, CHAR, COUNT); 

DCL  (ADDR .COUNT)  ADDRESS, 

(CHARyDEST  BASED  ADDR)  BYTE; 

DO  WHILE  (COUNT  :«  COUNT  -  1)  <>  0FFFFH; 

DEST  -  CHAR? 

ADDR  »  ADDR  ♦  1? 

END? 

END  PILL? 
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/*  *  *  * 

*  * 

SCANNER  LITS  * 

DCL  I NPUT$STR 

LIT 

'33', 

LITERAL 

LIT 

'15', 

PERIOD 

LIT 

'l'; 

/*  ?  *  #  #  SCANNER  TABLES  *  *  *  *  */ 

DCL  TOKEN$TABLE  (*)  BYTE  DATA 

/*  CONTAINS  THE  TOKEN  NUMBER  ONE  LESS  THAN  THE  FIRST 
RESERVED  WORD  FOR  EACH  LENGTH  OF  WORD  */ 
(0,0,1,4,5,15,22,33,40,46,49,51,53,58,60,61), 

TABLE(*)  BYTE  DATA ( 'FD', 'OF ', 'TO 'PIC 'COMP  ',  'DATA  ',  'FILE ' 

, 'LEFT ' , 'MODE' , 'SAME ' , 'S IGN ' , 'SYNC ' ,  'ZERO ' , 'BLOCK ' 

, 'LABEL', 'QUOTE', 'RIGHT', 'SPACE' , 'USAGE ',  'VALUE ' ,  'ACCESS  ' 
.'ASSIGN', 'AUTHOR',  'COMP-3 ', 'FILLER  ',  'OCCURS ', 'RANDOM ' 

, 'RECORD' , 'SELECT ', 'DISPLAY' , 'INDEXED  '  ,  'LEADING ' 
.'LINKAGE',  'OMITTED', 'RECORDS ', 'SECTION ', 'DIVISI ON ' 
.'RELATIVE',  'SECURITY',  'SEPARATE ',  'STANDARD ',  'TRAILING' 

, 'DEBUGGING ' , 'PROCEDURE ' , 'REDEFINES ' . 'PROGRAM-ID  ' 
.'SEQUENTIAL', 'ENVIRONMENT'. 'I-O-CONTROL', 'DATE-WRITTEN' 
.'FILE-CONTROL', 'INPUT-OUTPUT ',' INSTALLATION ' 

. 'ORGANIZATION  '  , 'COMPUTATI ONAL' , 'CONFIGURATION ' 
.'IDENTIFICATION', 'OBJECT-COMPUTER', 'SOURCE-COMPUTER' 

, 'WORKING-STORAGE'), 


OFFSET  (16)  ADDRESS 


/*  NUMBER  OF 

BYTES  TO 

INDEX  INTO  THE  TABLE  FOR  EACH 

LENGTH  V 

INITIAL  (0,0, 

0,6,9,45, 

80,134,183,231,258,278. 

300,360, 

366,400), 

WORD$COUNT  (*)  BYTE  DATA 

/*  NUMBER  OF 

WORDS  OF 

EACH  SIZE  V 

(0,0, 3, 1,9, 7, 

9, ?. 6, 3, 2 

,2, 5, 2,1, 3), 

ACCUM$LEN  $P$1 

LIT 

'51',  /*  ACCUMSLENG  PLUS  1  */ 

ACCUM  (ACCUM$LEN$P$1 ) 

BYTE, 

ACCUM$LENG 

LIT 

'50'. 

ADD$END(* ) 

BYTE 

DATA( '  PROCEDURE'), 

BUFFERS END 

ADDRESS 

INITIAL( 100H ) , 

CHAR 

BYTE 

INITIAL(CR), 

DISPLAY(88) 

BYTE 

INITIAL (5, '  1  '), 

FIRSTSLINE 

BYTE 

INITIAL(TRUE), 

FORMFEED 

LIT 

'0CH' , 

HOLD 

BYTE, 

INBUFF 

LIT 

'80H ' , 

LOOKED 

BYTE 

INITIAL(FALSE), 

MAXSLEN 

LIT 

'15', 

NEXT 

BASED 

POINTER  BYTE, 

TAB 

LIT 

'09', 
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TOON  byte;  /*returned  from  scanner  #/ 

/*****  procedures  used  by  the  scanner  *  *  *  */ 

NEXT$CHAR:  proc  byte; 

IF  LOOKED  THEN 

do; 

LOOKED  =  FALSE; 

RETURN  (CHAR  :=  HOLD); 

end; 

IF  (POINTER: “POINTER  +  1 )  >=  BUFFER$END  THEN 

do; 

IF  NOT  MORE$IN PUT  THEN 

do; 

BUFFER$END  “  .MEMORY; 

POINTER  =  .ADD$END; 

end; 

ELSE  POINTER  “  INBUFF; 

end; 

IF  NEXT  =  EOFFILLER  THEN 

do; 

BUFFER$END  *  .MEMORY? 

POINTER  =  .ADD$ENDJ 

end; 

RETURN  (CHAR  :*  NEXT); 

END  nextschar; 

GETSCHAR:  PROC? 

char=next$char; 
end  getschar; 

DISPLAY$LINE:  proc; 

dcl  I  byte; 

DO  I  “  1  TO  DISPLAY (0 ) ; 

IF  LISTS  INPUT  OR  ERROR  THEN  CALL 
PFINTCHAR(DISPLAT(I)); 

IF  WRITESLST  OR  ERROR  THEN 

CALL  WRITE$TO$DISK(DISPLAT(I)); 

end; 

CALL  INC$CTR ( .DISPLAY ( 0 ) ) ; 

DISPLAT(0)  *  5; 

END  DISPLATSLINE? 

LOADSDISPLAT:  PROC t 

IF  DISPLAY(0 )  <  87  THEN 

DISPLAY (DISPLAY (0 )  :»  DISPLAY(0)  +  1)  =  CHAR; 

call  get$char; 

END  loadsdisplay; 

PUT:  proc; 

IF  ACCUM(0)  <  ACCUMSLENG  THEN 


ACCUM(ACCUM(0)  :»  ACCUM(0)  ♦  1)  *  CHAR* 

CALL  LOAD$DISPLAY? 

END  PUT? 

SAT$LINE:  PROC? 

DO  WHILE  CHAR  <>  CR? 

CALL  LOAD$DISPLAT? 

END? 

END  EAT$LINE? 

GET$NO$BLANK :  PROC? 

DCL  I  BITE? 

DO  FOREVER? 

IP  (CHAR  -  '  '  OR  CHAR  =  TAB)  THEN  CALL  LOAD$DISPLAT ? 
ELSE  IP  CHAR=CR  THEN 
DO? 

IP  FIRST$LINE  THEN 
DO? 

FIRST$LINE  *  FALSE? 

CALL  GET$CHAR ? 

END? 

ELSE 

DO? 

CALL  LOAD$DI SPLAT? 

CALL  LOAD$DISPLAY? 

CALL  DISPLAY$LINE ? 

CALL  PHI NT$ERROR( TRUE)? 

END? 

DO  WHILE  CHAR  «  CR? 

CALL  LOAD$DI SPLAT? 

CALL  LOAD$DISPLAY? 

CALL  DISPLAT$LINE? 

END? 

IP  SEQ$NUM  THEN 
DO  I  *  1  TO  6? 

CALL  LOAD$DI SPLAT? 

END? 

IP  CHAR  «  THEN  CALL  EAT$LINE? 

ELSE  IP  CHAR  «  '/'  THEN 
DO? 

IP  LIST$INPUT  THEN 

CALL  PRINT$CHAR(FORM$FEED) ? 

IP  WRITE$LST  THEN 

CALL  WRITE$T0$DISK (FORM$FEED) ? 
CALL  SATLINE? 

END? 

ELSE  IP  CHAR  »  THEN 
DO? 

IP  NOT  DEBUGGING  THEN  CALL  EAT$LINE? 
ELSE  CALL  LOAD$DISPLAT? 

END? 
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end; 

else  return; 

END?  /*  END  OE  DO  FOREVER  V 

END  get$no$blank; 

SPACE:  PROC  BITE? 

RETURN  (CHAR  ■  '  ')  OR  (CHAR  -  CR)  OR  (CHAR  =  TAB); 
END  space; 

DELIMITER:  PROC  BITE; 

IF  CHAR  <>  THEN  RETURN  FALSE? 

HOLD  *  NEXT$CHAR? 

LOOKED  -  TRUE? 

IF  SPACE  THEN 

do; 

CHAR  -  '.'? 

RETURN  TRUE? 

end; 
char  « 

RETURN  FALSE; 
end  DELIMITER; 

END$OF$TOKEN :  PROC  BYTE; 

RETURN  SPACE  OR  DELIMITER; 

END  end$of$token; 

GET$LITERAL:  PROC  BITE? 

call  load$displat; 
do  forever; 

IF  CHAR  -  QUOTE  THEN 

do; 

CALL  LOAD$DI SPLAT? 

RETURN  LITERAL? 

end; 

CALL  PUT? 

end; 

end  get$literal; 

LOOKSUP:  PROC  BITE? 

DCL  POINT  ADDRESS .HERE  BASED  POINT(l)  BITE,  I  BYTE? 

MATCH:  PROC  BITE? 

DCL  J  bite; 

DO  J  -  1  TO  ACCUM(0); 

IF  HERE(J  -1)0  ACCUM(J)  THEN  RETURN  FALSE 

end; 

RETURN  TRUE? 

END  MATCH? 

POINT  ■  OPFSET(ACCUM(0) )  ♦  .TABLE? 

DO  I  -  1  TO  VORD$COUN  T( ACCUM ( 0 ) ) ? 


IF  MATCH  THEN  RETURN  IJ 
POINT  *  POINT  ♦  ACCUM(0) ; 

end; 

RETURN  FALSE; 

END  LOOE$UP; 

RESERVED$¥ORD :  PROC  BITS; 

DCL  (NUMB ,VALUE)  BITE; 

IF  ACCUM(0)  >  MAX$LEN  THEN  RETURN  0; 

IF  (NUMB  TOKEN $TABLE(ACCUM(0) ) )  *  0  THEN  RETURN  0? 
IF  (TALUE  :*  LOOK$UP>  -  0  THEN  RETURN  0; 

RETURN  (NUMB  +  VALUE); 

END  reserved$word; 

GET$TOKEN:  PROC  BITE? 

ACCUM(0)  *  0; 

CALL  get$no$blank; 

IF  CHAR  «  QUOTE  THEN  RETURN  GET$LITERAL; 

IF  DELIMITER  THEN 

do; 

CALL  put; 

RETURN  PERIOD; 

end; 

do  forever; 
call  put; 

IF  EN D$OF$TOKEN  THEN  RETURN  INPUT$S?R; 

END»  /*  OF  DO  FOREVER  */ 

END  get$token; 

SCANNER:  PROC; 

DCL  CHECK  BTTE» 

do  forever; 

IF(TOKEN  :»  GETSTOKEN)  -  INPUT$STR  THEN 
IF  (CHECK  RESERVSD$VORD)  <>  0  THEN 
TOKEN  *  CHECK; 

IF  TOKEN  <>  0  THEN  RETURN,* 

CALL  PRINT$ERROR  ('SE'); 

DO  WHILE  NOT  END$OF$TOKEN J 
CALL  get$char; 
end; 

end; 

end  scanner; 

PRINT$ACCUM:  PROC; 

DCL  I  bite; 

DO  I  “  1  TO  ACCUM(0); 

CALL  PRINT$CHAR(ACCUM(I)); 

CALL  WRITS$TO$DISK(ACCUM(I)); 

end; 

CALL  crlf; 
call  dcrlf; 
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INS  PRINT$ACCUM; 


PRINT$NUMBER:  PROC(NUMB); 

DCL( NUMB , I ,CNT,K )  BITE,  J(*)  BITE  DATA (100 ,10 ) J 
DO  I  -  0  TO  1J 
CNT  -  0; 

DO  WHILE  NUMB  >-  (K  J(I))? 

NUMB-NUMB  -  Ki 
CNT-CNT  ♦  15 

end; 

CALL  PRINTCHAR('0'  ♦  CNT),* 

end; 

CALL  PRINTCHAR('0'  +  NUMB); 

END  PRINTS NUMBER? 

INIT$SCANNER:  PROCJ 

DCL  CON$CBL  (*)  BITE  DATA  ( 'CBL') ,(TESTFLAG,I )  BITE? 

CALL  MOTE(PARMS , .PARMLIST, 8) i 
IF  PARMLIST (0)  =  THEN 

do; 

1  1-05 

DO  WHILE  (TESTFLAG  s-  PARMLIST (I  I  +  1))  O  '  '; 

IF  TESTFLAG  »  'L'  THEN  LIST$INPUT  *  NOT  LIST$INPUT; 

IF  TESTFLAG  *  'S '  THEN  SEQ$NUM  «  NOT  SEQ$NUMi 

IF  TESTFLAG  -  THEN  PRINT$PROD  «  NOT  PRINT$PROD; 

IF  TESTFLAG  -  'T'  THEN  PRINT$TOKEN  *  NOT  PRI NT$T0KEN 

IF  TESTFLAG  -  'C'  THEN  NO$CODB  -  NOT  NOSCODEJ 

IF  TESTFLAG  -  'W'  THEN  WRITE$LST  *  NOT  WRITESLST; 

IF  TESTFLAG  -  'D'  THEN  DEBUGGING  -  NOT  DEBUGGING; 

end; 

end; 

CALL  MOTE(.CON$CBL,IN$ADDR  +  9,3); 

CALL  FILL (IN$ADDR  ♦  12,0,5); 

CALL  open; 

IF  NOT  NO$CODE  THIN 

do; 

CALL  MOYE(INADDR,.OUTPUT$FCB,9)5 
0UTPUT$FCB(32)  -  0; 

OUTPUT ^END  -  (OUTPUT$PTR  s*  .OUTPUT$BUF?  -  1)  +126 
CALL  MAKE(.OUTPUT$FCB); 

end; 

CALL  M0VI(INADDR,.LIST$FCB,9); 

LISTSFCB (32  )  «  0; 

LIST$END  -  (LIST$PTR  t-  ,LIST$BUF?  -  1)  ♦  128; 

CALL  make(.list$fcb); 

CALL  GET$NO$BLANK;  /*  PRIME  THE  SCANNER  */ 

CALL  PRINT$ERROR( FALSE); 

CALL  PRINT(.('NPS  MICRO-COBOL  COMPILER  VERSION  2.0', 
CR,LF,LF, '$')); 

END  init$scanner; 


/*  *  *  *  END  0?  SCAMMER  PROCEDURES  *  *  *  */ 

/****•  SYMBOL  TABLE  DECLARATIONS  *  *  *  */ 


DCL 

ADDR2 

LIT 

'4', 

CUR$SYM 

D$CNT 

ADDRESS, 

BYTE, 

/•SYMBOL  BEING  ACCESSED*/ 

DECIMAL 

LIT 

'11'. 

DISPLACEMENT 

LIT 

'14', 

EL$CNT 

LIT 

'6', 

HASH$MASE 

LIT 

'3EH', 

LEVEL 

LIT 

'10'. 

LOCATION 

LIT 

'2'. 

MAX4ID$LEN 

LIT 

'15'. 

NEXT$SYM$ENTRY 

BASED  NEXT$SYM 

ADDRESS, 

OCCURS$PTR 

ADDRESS 

INITIALS), 

P$LENGTH 

LIT 

'3'. 

RELSID 

SAVE$ADDR 

LIT 

ADDRESS, 

'5', 

S$LENGTH 

LIT 

'3'. 

S$TYPE 

LIT 

'2'. 

START$NAME 

LIT 

'13',  /*1  LESS*/ 

SYMBOL 

BASED  CUR$SYM( 1 ) 

BYTE, 

symbolsaddr 

TEMP$PTR 

BASED  CUR$SYM( 1 ) 
ADDRESS, 

ADDRESS , 

TEMP$ADDR 

BASED  TEMP$PTR 

ADDRESS, 

TEMP$BYTE 

BASED  T1MP$PTR 

BYTE? 

/*  *  * 

*  * 

TYPE  LITERALS  * 

*******/ 

DCL 

COMP 

LIT 

21  , 

CROUP 

LIT 

'6', 

OCCURS$TYPE 

LIT 

'128', 

RANDOM 

LIT 

'3', 

RELSXEY 

LIT 

'25', 

REL$IEY$UR 

LIT 

'28' 

SEQUENTIAL 

LIT 

'1', 

SEOSRELATIVE 

LIT 

2  . 

UR$MASK 

LIT 

'128', 

VARIABLE$LENC 

LIT 

'4'; 

/*  *  *  *  SYMBOL  TABLE  ROUTINES  *  *  *  */ 

IN I T$ SYMBOL:  PROCi 

/*  INITIALIZE  HASH  TABLE  AND  PIRST  COLLISION  FIELD  */ 
CALL  BILL  (EREE$STORAGE,0, 130) » 

NEZT$SYM  -  EREESSTORACE  4-  128  J 
NEXT$SYM$ENTRY  -  0? 

END  INIT$SYMBOL? 


GET$P$LENGTHs  PBOC  BITE; 

RETURN  STMBOL(P$LENGTH) * 

END  GET $P$ LENGTH! 

SET$ADDRESS:  PROC(ADDR) » 

DCL  ADDR  ADDRESS! 

SYMBOL$ADDR (LOCATION)  *  ADDR! 

END  SET$ADDRESS! 

GET$ADDRESS:  PROC  ADDRESS! 

RETURN  STMBOL$ADDR (LOCATION)! 

END  GETSADDRESS! 

GETS TYPE:  PROC  BITE! 

RETURN  SYMBOL(S$TYPS)! 

END  GET$TYPE! 

SET$TYPE:  PROC(TYPE)! 

DCL  TYPE  BYTE! 

SYMBOL (S$TYPE)  -  TYPE! 

END  SETSTYPE! 

OR$TYPEj  PROC (TYPE)! 

DCL  TYPE  BYTE! 

SYMBOL(S$TYPE)  -  TYPE  OR  GET$TYPE 
END  or$type; 

GETSLEVEL:  PROC  BYTE! 

RETURN  SYMBOL (LEVEL)! 

END  GET$LEVEL! 

SETSLEVELj  PROC  (LVL); 

DCL  LVL  BYTE! 

SYMBOL (LEVEL)  «  LVL! 

END  sethevel; 

GETSDECIMAL:  PROC  BYTE! 

RETURN  SYMBOL (DECIMAL)! 

END  getsdecimal; 

SETSDECIMAL:  PROC  (DEC); 

DCL  DEC  BYTE! 

SYMBOL (DECIMAL)  -  DEC; 

END  SET$DECIMAL! 

SET$S$LENGTH:  PROC (HOW$LONG) ! 

DCL  ROWS LONG  ADDRESS! 
SYMBOL$ADDR(S$LENGTH)  *  E0tf$L0NG! 
END  SET$S$ LENGTH! 


GET$S$ LENGTH:  PHOC  ADDRESS? 

RETURN  SYMBOL$ADDR(SSLENCTH) ; 

END  GET$S$LENGTH? 

SETSADDR2:  PROC  (ADDR) ; 

ECL  ABDR  ADDRESS? 

SYMB0L$ADDR(ADDR2)  -  addr; 

END  SET$ADDR2» 

SET$TBL$SIZE:  PROC(OCCUR); 

dcl  occur  address; 

SYMBOLS ADDR ( EL$CN T )  *  OCCUR; 

end  setstblssize; 

GETSTBLSSIZE:  PROC  ADDRESS; 

RETURN  SYMBOL$ADDR(EL$CNT) * 

end  getstblssize; 

SET$IO$ADDRS:  PROC? 

SYMBOL$ADDR( LOCATION)  -  NEXTSSYM? 

SAYESADDR  *  CURSSYM? 

END  SET$IO$ADDRS; 

GET$PREV$OCCURS :PROC  ADDRESS; 

TEMPSPTR  *  CURSSYM  ♦  STARTNAME  ♦  GETSPSLENGTH ; 
RETURN  TEMPS ADDR; 

END  GETSPREYSOCCURS; 


processsoccursiproc; 

TEMPSPTR  »  NEXTSSYM? 

NEXTSSYM  -  NEXTSSYM  ♦  3; 

TEMPSADDR  «  OCCURSSPTR;  /*SET  PTR  TO  PREVIOUS  OCCURS*/ 
CALL  ORSTYPE (OCCURS STYPE); 

TEMPSPTR  -  TEMPSPTR  ♦  2; 

tempsbyte  -  dscnt; 

END  PROCESSSOCCURSJ 

/*  *  *  *  PARSER  DECLARATIONS  *  *  *  */ 

DCL 


COMPILING 

BYTE 

INITIAL  (TRUE ) , 

HOLDSLIT (ACCUMSLEN S?S1 ) 

BYTE, 

HOLDSSYM 

ADDRESS, 

IDSSTACX (10) 

ADDRESS 

INITIALS), 

IESSTACKSPTR 

BYTE 

INITIALS), 

INT 

LIT 

'67',  /*  INITIALIZE 

(I.J.f) 

BYTE, 

MP 

BYTE, 

MPP1 

BYTE, 

NOLOOf 

BYTE 

INITIAL(TRUE), 

REDE? 

BYTE 

IN ITIAL(PALSE) , 

REDEPSONE 

ADDRESS , 

REDE? S TWO 

ADDRESS , 

PENDINGSLITERAL 

BITE 

PENDINGSLITSID 

ADDRESS 

PSTACKSIZE 

LIT 

SCD 

LIT 

SP 

BYTE 

STATE 

BITE 

STATESTACK (PSTACKSIZE) 

BYTE, 

TEMPSHOLD 

ADDRESS 

TEMPSTWO 

ADDRESS 

TRUNCSFLAG 

BYTE 

VALUE( PSTACKSIZE) 

ADDRESS 

VALUESFLAG 

BYTE 

VALUESLEVEL 

BITE 

VARC(5l) 

bite; 

INITIAL(FALSE)  , 

'40',  /*  SIZE  OF  STACKS  */ 
'70',  /*  COTE  START  */ 
IIIITIAt(255) , 

INITIAL (STARTS ) , 

/*  SAVED  STATES  */ 


IN  IT IAL( TRUE) , 

/*  TEMP  VALUES  */ 

INITIAL(FALSF), 

INITIALS), 

/♦TEMP  CHAR  STORE*/ 


/*  *  *  *  PARSER  ROUTINES  ***♦*/ 

BYTESOUT:  PROC(ONESBITE) ; 

DCL  ONESBYTE  BITE? 

IF  NOSCODE  THEN  RETURN i 

IF  (OUTPUTSPTR  :«  OUTPUT$PTR  ♦  1)  >  OUTPUTSEND  THEN 
DO 

CALL  VRITE$OUTPUT( .OUTPUTSBUFF, .OUTPUTSFCB) ; 

output$ptr«. outputsbuff; 

end; 

OUTPUT$CHAR  »  ONESBYTE; 

END  btte$out; 

STRING$ OUT :  PROC  (ADDR, COUNT ) ; 

DCL  (ADDR, I, COUNT)  ADDRESS,  CHAR  BASED  ADDR  BITE; 

DO  I  »  1  TO  count; 

CALL  BYTESOUT ( CHAR ) J 
ADDR  «  ADDR+i; 

end; 

end  stringsout; 

ADDRSOUT:  PROC (ADDR); 

DCL  ADDR  ADDRESS; 

CALL  BYTESOUT (LOW (ADDR)) ! 

CALL  BYTESOUT (HIGH (ADDR)); 

end  addrsout; 

FILLSSTRING:  PROC (COUNT, CHAR) ; 

DCL  (I, COUNT)  ADDRESS,  CHAR  BITE; 

DO  I  -  1  TO  count; 

CALL  BYTESOUT (CHAR); 

end; 

END  FILLSSTRING; 

STARTS INITIALIZE:  PROC (ADDR ,CNT) i 
DCL  (ADDR.CNT)  ADDRESS; 


CALI  BTTEOUT(INT), 

CALL  ADDR$OUT(ADDR); 

CALL  ADDR$OUT(CNT) ; 

INS  STARTS  IN ITIALIZE; 

BUILD$SYMBOL:  proc(len); 

DCL  LIN  BITIV  TEMP  ADDRESS,* 

temp  -  nextssym; 

IE  (NEXT$SYM  .SYMBOL (LEN  :«  LEN  +  DISPLACEMENT)) 

>  MAX$M!MORY  TEEN  CALL  7ATAL$ERR0R(  'ST') J 
CALL  EILL  ( TEMP .0, LEN); 

END  buildssymbol; 

MATCH:  PROC  ADDRESS,* 

/*  CHECKS  AN  IDENTIEIBR  TO  SEE  IP  IT  IS  IN  THE  SYMBOL 
TABLE.  IE  IT  IS  PRESENT,  CUR$SYM  IS  SET  FOR  ACCESS. 
OTHERVISE  A  NEW  ENTRY  IS  MADE  AND  THE  PRINT  NAME 
IS  ENTERED.  ALL  NAMES  ARE  TRUNCATED  TO  MAX$ID$LEN*/ 

DCL  POINT  ADDRESS .COLLISION  BASED  POINT  ADDRESS, 

(HOLD, I)  byte; 

IE  fARC(0)  >  MAX$ID$LEN 

THEN  PARC (0)  ■  MAX$ID$LENJ  /*  TRUNCATE  IE  REQUIRED  */ 
HOLD  «  0; 

DO  I  «  1  TO  VARC(0)J  /*  CALCULATE  HASH  CODE  V 
HOLD  »  HOLD  +  YARC(I); 

end; 

POINT  «  EREE$STORAGE  +  SHL( (HOLD  AND  BASH$MASK) , 1 ) ; 
UI$ELAG  -  FALSE,* 

do  eoreyer; 

IE  COLLISION  *  0  THEN 

do; 

UISFLAG  -  true; 

CUR$SYM, COLLISION  -  NEXTSSYM.; 

CALL  BUILD$SYMBOL(?ARC(0)); 

SYMBOL ( P$LENGTH )  -  ?ARC(0); 

DO  I  -  1  TO  TARC(0); 

SYMBOL ( STARTS NAME  +  I)  ■  YARC(I); 

end; 

RETURN  CURSSYM; 

end; 

ELSE 

do; 

CUR$SYM  -  collision; 

IE  (HOLD  GET$P$LENGTH)  «  YARC(0)  THEN 

do; 

I  -  1? 

DO  WHILE 

SYMBOL(START$NAME  +  I)  *  VARC(I); 
IE  (I  :■  I  ♦  1 )  >  HOLD  THEN 

RETURN  (CUR$SYM  :=  COLLISION); 

end; 

end; 
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end; 

point  •  collision; 

end; 

end  match; 

ALLOCATE:  PROC(BYTES$REQ)  ADDRESS; 

DCL  (HOLD  .BYTES  $REQ)  ADDRESS; 

HOLD  «  next$ayailable; 

IE  (NEIT$AVAILABLE  :=  N  EXT  $  AVAILABLE  +  BTTES$RE0) 

>  MAX$INT$MEM  THEN 
CALL  EATAL$ERROR('MO'); 

RETURN  HOLD; 

END  allocate; 

DIGIT:  PROC (CHAR )  BITS; 

DCL  CHAR  BITE; 

RETURN  (CHAR  <»  '9')  AND  (CHAR  >«  '0 ' )  J 
END  digit; 

SET$REDEE:  PROC (OLD, NEW); 

DCL  (OLD, NEW)  ADDRESS; 

REDEF$ONE  *  OLD? 

REDEE$TWO  «  NEW; 

REDEE  -  TRUE; 

END  set$redef; 

SET$CUR$STM:  PROC; 

CURSSTM  *  ID$STACX(ID$STACK$PTR) ; 

END  set$cur$sym; 

STACX$LEVEL:  PROC  BITE; 

CALL  set$cur$stm; 

RETURN  GETUEVEL; 

END  stack$level; 

LOAD$LEVEL:  PROC; 

DCL  HOLD  ADDRESS; 

LOAD$REDEE$ ADDR :  PROC; 

CURSSTM  -  redee$one; 

HOLD  *  GET$ADDRESS; 

END  load$rsdee$addr; 

IE  ID$STACI(0)  <>  0  THEN 

do; 

IE  VALUE (SP  -  2)  -  0  THEN 

do; 

call  set$cur$sym; 

HOLD  -  GETSSSLENGTH  ♦  GETSADDRESS* 

end; 

ELSE 
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do; 

IF  FILE$SSC$END  TEEN 

do; 

IF  ID$STACI(ID$STACK$PTR)  o  fedef$one 
TEEN 

do; 

CALL  PRINT$ERR0R('R1'); 

REDEF$0NE  *  ir$STACZ(ID$STACK$PTR) 

end; 

end; 

CALL  load$redef$addr; 
end; 

IF  (ID$STACK$PTR  :=  ID$STACK$PTR  +  l)  >  9  TEEN 

do; 

CALL  PRINT$ERR05(  'EL')»* 

ID$STACK$PTR  =  9} 

end; 

end; 

ELSE  hold  »  next$atailable; 

CUR$STM,ID$STACK( II$STACK$PTR)  *  7ALUE(MPP1); 

IF  (CUR$SYM<>OCCURS$PTR)  AND  (D$CNT<>0)  THEN 
CALL  PROCESS$OCC0RS; 

IF  (GET$LEVEL  -  1)  AND  (NOT  ?ILE$SEC$END)  THEN 
CALL  SET$ADDR2(SATE$ADDR); 

CALL  SET$ADDRESS (HOLD) ; 

END  L0AD$LE7EL; 

REDEF$OR$TALUE:  PROC; 

DCL  (HOLD .HOLD1, TEMP)  ADDRESS  , 

(CHAR,LVL$NBR)  BTTEJ 
IF  REDEF  THEN 

do; 

IF  REDEF$TVO  =  CUR$STM  THEN 

do; 

hold  *  get$s$length; 

LTL$NBR  -  GET$LETEL; 

CUR$STK  *  redef$one; 

IF  HOLD  <>  (H0LD1  :*  GFT$S$LENGTE)  THEN 

do; 

IF  (L7L$NBR  »  1) 

AND  (NOT  FILE$SEC$END )  THEN 

do; 

cur$stm  =  safe$addr; 

CALL  SET$TTPE ( 7ARIABLE$LENG ) 
IF  HOLD>HOLDl  THEN 

CALL  SET$S$LENGTH(POLD); 

ELSE 

CALL  SET$S$LENGTH(HOLDl) 

end; 

IF  HOLD  >  ROLD1  THEN 

do; 


IF  LVLSNBR  =  1  THEN 

TEMP  *  ALLOCATE (HOLD  -  SOLDI )» 
ELSE 

do; 

CALL  PRINTSERROR( 'R2'); 
COR$STM  =  REDFFSTVOJ 
CALL  SET$S$LENGTH(HOLD); 

end; 

end; 

end;  /*  END  IF  HOLD  <>  */ 

END;  /*  END  IF  REDEFSTWO  =  CURSSYM  */ 

END;  /*  END  IF  REFEF  */ 

ELSE  IF  PENDINGSLITERAL  =  0  THEN  RETURN; 

IF  (PENDING$LIT$IDOID$STACK$PTR)  OR  VALUES  FLAG  THEN 

return; 

IF  PENDINGSLITERAL  <>  0  THEN 

CALL  STARTS INITIALIZE (GETS ADDRESS 'HOLD 

getssslength); 

IF  PENDINGSLITERAL  >  2  THEN 

do; 

IF  PENDINGSLITERAL  *  3  THEN  CHAR  =  '0'; 

ELSE  IF  PENDINGSLITERAL  =  4  THEN  CHAR  =  '  '; 

ELSE  IF  PENDINGSLITERAL  =  5  THEN  CHAR  =  QUOTE; 
CALL  FILLSSTRING(HOLD'CHAR); 

end; 

ELSE  IF  PENDINGSLITERAL  =  2  THEN 

do; 

IF  HOLD  <«  HOLD$LIT(0)  THEN 

CALL  STRING$O0T( ,HOLD$LIT(l ),HOLD)» 

ELSE 

do; 

CALL  STRING$OUT( .H0LD$LIT(1 ) ,HOLI$LIT(0) ) ; 
CALL  FILLSSTRl NG ( HOLD  -  HOLD$LIT(0) , '  '); 

end; 

end; 

ELSE  IF  PENDINGSLITERAL  »  1  THEN 

do; 

DCL  (H$DEC ,H$LENGTH,H ,L,L$DEC 'LSLENGTH, SIGN , TYPE) 
BITE,  TEMP( 20)  BYTE,  ZONE  LIT  '80H'; 

IF  ((TYPE  GETSTYPE)  <  16  OR  (TYPE  >  21  THEN 
CALL  PRINT$ERROR( 'NV'); 

LSLENGTH  *  GETSLENGTHt 

LSDEC  -  LSLENGTH  -  GETSDECIMALJ 

IF  TYPE  «  20  THEN  LSDEC  =  LSDEC  0  i; 

HSLENGTH  -  HOLD$LIT(0); 

HSDEC  «  HSLENGTH  +  l; 

SIGN  -  '«■'? 

IF  HOLDSLIT(l)  =  THEN 
SIGN  - 

DO  H  »  1  TO  HSLENGTH; 

IF  HOLDSLIT(H)  *  THEN  HSDEC  «  H; 


DO  L  *  0  TO  19; 

TEMP(L)  =  ' 0 

end; 

L  =  L$DEC  -  i; 

H  *  H$DEC ; 

DO  WHILE  (((L  :=  L  ♦  1)  <  L$LENGiii)  AND 
((H  :»  H  +  1)  <*  H$LENGTH)); 

TEMP(L)  *  HOLD$LIT(H); 

end; 

L  *  L$DEC; 

H  »  H$DEC ; 

DO  WHILE  < ( <L  L  -  1)  <  255)  AND 
((H  :=  H  -  1)  >  0)  AND 
(HOLD$LIT(H)  <>  SIGN)); 

TEMP(L)  *  HOLD$LIT(H); 

end; 

IP  ( <H  >  1)  OR 

((H  =  1)  AND  (HOLD$LIT(l)  <>  SIGN)))  THEN 
CALL  PRINT$ERROR('SL'); 

IF  SIGN  *  THEN 
IF  TYPE  «  17  THEN 

TEMP(0)  =  TEMP(0)  OR  ZONE; 

ELSE  IF  TYPE  =  18  THEN 

TEMP(L$LENGTH)  =  TEMP (L$LENGTH)  OR  ZONE; 
IF  TYPE  *  19  THEN 

do; 

IF  TEMP(0)  <>  '0'  THEN 

CALL  PRINT$ERROR('SL'); 

TEMP ( 0 )  »  sign; 

end; 

ELSE  IF  TYPE  »  20  THEN 

TEMP(L$LENGTH  -  1)  *  SIGN; 

IF  TYPE  »  21  THEN 

do; 

IF  SIGN  -  THEN 

TEMP(L$LENGTH)  =  '0'; 

ELSE  TEMP(L$LENGTH)  »  'l'l 
IF  (L$LENGTH  MOD  2)  THEN  L  =  05 
ELSE 

do; 

CALL  BYTE$ODT(TEMP(0)  -  30H)J 
L  -  i; 

end; 

DO  WHILE  L  <  L$LENGTH; 

CALL  BYTE$ODT (SHL( (TEMP(L)  -  30H),4) 
OR  (TEMP(L  +  1)  -  30H)); 

L  »  L  +  2? 

end; 

DO  I  ■  L$LENGTH  /  2  +  2  TO  L$LENGTH; 

CALL  BYTE$OUT(00H): 


end; 

end; 

ELSE  CALL  STRING$OUT( .TBMP,L$LENGTH); 

end; 

If  NOT  FALUE$FLAG  THEN  PENDING^ LITERAL  =  0; 

END  redef$or$falue; 

REDUCE$STACK :  PROCJ 

DCL  HOLD$LFNGTH  ADDRESS; 

CALL  set$cur$stm; 

CALL  REDEF$OR$ VALUE; 

HOLDHENGTH  *  GET$S$LENGTH J 

IF  GBT$TYPE  >  OCCURS$TYPE  AND  GET$TBL$SIZE  <>  0  THEN 
do; 

HOLD$LENGTH«HOLD$LENGTH  *  GET$TBL$SIZE; 

IF  (D$CNT  s*  D$CNT  -  1)  <>  0  THEN 
OCCURS$PTR  =  GET$PREV$OCCURS; 

ELSE  OCCURS$PTR  »  0; 

end; 

ID$STACK$PTR=ID$STACK$PTR  -  l; 

CALL  set$cur$stk; 

CALL  SET$S$LENGTH(GET$S$LENGTH  +  HOLD$LENGTH) J 
CALL  OR$TTPE (GROUP); 

END  REDUCE $STACC; 

END$OF$RECORD:  PROC; 

DO  WHILE  ID$STACK$PTR  <>  0; 

CALL  set$cur$sym; 
call  redef$or$falue; 

ID$STACK ( ID$STACK$PTR)  *  0; 

ID$STACK$PTR  «  ID$STACE$PTR  -  X; 

end; 

call  set$cur$stm; 
call  redef$or$falue; 

ID$STACE(0)  «  0; 

TBMP$HOLD  -  ALLOCATE(GET$S$LENGTH); 

end  end$of$record; 

C  ONFERT$ I NTEGER :  PROCi 
DCL  INTEGER  ADDRESS; 

INTEGER  >  0; 

DO  I  «  1  TO  VARC(0); 

IF  NOT  DIGIT(FARC(I))  THEN  CALL  PRINT$ERROR(  'NN') 
INTEGER  ■  SHL( INTEGER»3 )  +  SHL( INTEGER ,1 )  + 

(FARC ( I )  -  '0'); 
end; 

FALUE(SP)  -  INTEGER; 

END  CONVERT* INTEGER? 

ORSFALUE:  PROC(PTR, ATTRIB) J 

DCL  PTR  BITE,  ATTRIB  ADDRESS; 
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TALUS (PTE)  »  TALUS (PTR)  OR  ATTRIBi 
END  OR$TALUE? 

BUI LDSFCB:  PROCJ 

DCL  TEMP  ADDRESS? 

DCL  BUPPER(12 )  BITE, (CHAR, I ,J)  BITE; 

CALL  f ILL( .BUP7ER , '  ,12); 

IE  TARC (2 )  «  's'  THEN 

do; 

BUFFER(0)  =  7ARC(1)  AND  0FH» 

I  »  2; 

end; 

ELSE 

do; 

BUSIER (0)  =  0; 

I  -  0; 

end; 

j  -  1; 

DO  WHILE  (J  <  12)  AND  (I<  TARC(0)); 

IE  (CHAR  :«  TARC(I  :*  I  +  D)  *  THEN  J  =  9; 

ELSE  do; 

BUFFER ( J )  »  CHAR.* 

J  =  J  +  i; 

end; 

end; 

CALL  SETSADDR2 (TEMP  :»  ALLOCATE ( 165  )) ; 

CALL  STARTS  IN ITIALIZE( TEMP, 37); 

CALL  STRING$CUT(. BUFFER, 12); 

CALL  EILL$STRING(25,0); 

CALL  OR$TALUE(SP  -  1,1); 

END  buildsecb; 

SETSSIGN:  PROC(NUMB); 

DCL  NUMB  BITE? 

IE  GETSTTPE  »  17  THEN  CALL  SET$TTPE( TALUE( SP)  ♦  NUMB); 
ELSE  CALL  PRlNT$ERROR( 'SG') ; 

IF  TALUE(SP)  <>  0  THEN 

CALL  SET$S$LENGTH(GET$S$LENGTH  ♦  1)J 
END  set$sign; 

NUM$TRUNC:  PROC; 

DCL  ( I ,J ,  TRUNC$TYPE,TRUNC$ ZERO , SIGNS FLAG, DECS FLAG)  BITE 
TRUNCSZERO  ■  TRUE; 

SIGNSELAG ,DEC$FLAG  -  FALSE; 

HOLD$LIT(0),I  ■  0; 

J  -  I? 

IE  ( (TRUNCSTTPE  GETSTTPE)  >-  16) 

AND  (TRUNCSTTPE  <■  21)  THEN 
DO  WHILE  J  <-  TARC(0)J 

IE  (TARC(J)  <>  '+')  AND  (TARC(J)  <>  '-')  THEN 

do; 


IP  (FARC(J)  *  '0')  AND  TRUNCSZERO  THEN  J  =  JJ 
ELSE  IP  ( ( PARC ( J)  >=  '0')  AND  (FARC(J)  <=  '9')) 
OR  (FARC(J)  »  THEN 

do; 

IF  DEC$FLAG  AND  (FARC(J)  *  THEN 

CALL  PRINT$ERROR('MD'); 

ELSE  do; 

HOLD$LIT(HOLD$LIT(0)  :=  HOLD$LIT(0)  +  1)  = 

farc(j); 

IF  FARC ( J )  <>  '0'  THEN  TRUNCSZERO  =  FALSE; 
IF  VARC( J )  -  THEN  DEC$FLAG  =  TRUE? 

I  «  I  +  i; 

end; 

end; 

ELSE  IF  ( ( VAPC( J )  <  '0')  OR  (VARC(J)  >  '9'))  AND 
(FARC(J)  <>  THEN  CALL  PRINT$ERROR( 'NN  ' ) ; 

end; 

ELSE  IP  SIGN$?LAG  THEN  CALL  PRINT$E3R0R( 'MS' ) ; 

ELSE  IP  (VARC(J)  =  '  +  '}  OR  (FARC(J)  *  THEN 

do; 

IF  TRUNC$TTPE  *  16  THEN 

CALL  PRINT$ERR0R('SG'); 

ELSE 

do; 

HOLD$LlT(HOLD$LIT (0 )  :  = 

HOLD$LIT(0)  +  1)=YARC(J); 
SIGN$FLAG  *  TRUE; 

1*1+1? 

end; 

end; 

j  »  j  +  i; 

end;/*  do  while  loop  */ 
hold$lit(0)  *  i; 

IP  ((HOLD$LIT(0)  -  1)  AND  ( ( HOLDSLIT ( 1 )  *  '+')  OR 
(EOLD$LIT (1 )  *  '-')))  OR  (HOLD$LIT(0)  *  '0')  THEN 
HOLD$LIT(0),HOLD$LIT(1)  *  0? 

END  NUM$TRtTNC; 

PIC$ANALIZER :  PROC? 

DCL  /*  WORK  AREAS  AND  FAR  I  ARLES  */ 

BUFFER (133)  BITE, 

CHAR  SITE, 

COUNT  ADDRESS, 

DECSCOUNT  BITE, 

DEC$ FLAG  BITE, 

DIGITS  BITE, 

FLAG  BITE, 

FLAGS (3)  BITE, 

FLOATSPSIT  BITE, 

FLOATSFALUE  BITE, 

I  BITE, 


J  ADDRESS, 

K  BITE, 

REPITITIONS  ADDRESS, 
SAVE  BITE, 

TEMP  ADDRESS , 

TYPE  BITE, 


/*  *  *  MASKS 

m  *  */ 

ALPHA 

LIT 

'i;. 

A5EDIT 

LIT 

'2' 

A$N 

LIT 

EDIT 

LIT 

'e\ 

NUM 

LIT 

'16', 

NUM$EDIT 

LIT 

'32', 

DEC 

LIT 

'64', 

SIGNED 

LIT 

'126', 

A$E$MASK 

LIT 

'11111100B 

A$N$MASK 

LIT 

'11101010B 

A$N$E$MASK 

LIT 

'11100000B 

ALPHASMASK 

LIT 

'mill  10B 

NUM$MASK 

LIT 

'10101111B 

NUM$ED$MASK 

LIT 

'10000101B 

S$NUM$MASK 

LIT 

'00101111B 

/*  TYPES 

V 

ATYPE 

LIT 

'8', 

AETIPF 

LIT 

'72', 

ANTIPE 

LIT 

'9\ 

ANETYPE 

LIT 

'73', 

NTYPE 

LIT 

'16', 

NETIPE 

LIT 

'80', 

SNTYPE 

LIT 

'I?'; 

INC$COUNTs  PROC (SWITCH ) j 
DCL  SWITCH  BTTEJ 
ELA6  *  PLAG  OR  SWITCH* 

IF  (COUNT  :*  COUNT  +  1)  <  133  THEN 
BUFFER (COUNT)  =  CHAR? 

END  incscount; 

CHECKS  PROC  (MASK)  BITE? 

DCL  MASK  BITE; 

RETURN  NOT  ((FLAG  AND  MASK)  <>  0 ) ; 

END  CHECK) 

PIC$ALLOCATE :  PROC (AMT)  ADDRESS; 

DCL  AMT  ADDRESS; 

IF  (MAX$INT$MEM  :  =  MAX$INT$MEM  -  AMT) 

<  NEXT$AVAILABLE  THEN  CALL  FATAL$E?ROR  ('MO'); 
RETURN  MAX$INT$MEM; 
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END  P I c$ allocate; 

SIGN:  PROC  (CHAR )  BYTE,' 

ecl  cbar  bite; 

RETURN  (CHAR  »  'O  OR  (CHAR  *  '-'); 

END  sign; 

FLOAT$CHECK:  PROC (I); 

DCL  I  BITE.* 

IP  FLOAT$VALUE  3  0  AND  TLAGS(I)  THEN 
FLOAT$VALUE  *  CHAR ; 

IF  CHAR  <>  FLOAT$7ALUE  AND  FLAGS (I)  THEN 
CALL  PRINT$ERROR('Pl'); 

IF  FLAGS (I)  THEN 

do; 

FLOAT$PSIT  *  COUNT  ♦  1,* 

DIGITS  «  DIGITS  +  1} 

end; 

ELSE 

FLAGS (I)  «  TRUE; 

CALL  INC$COUNT(NUtf$EDIT); 

END  ploat$check; 

/*  PROCEDURE  EXECUTION  STARTS  HERE  V 
CUR$SYM  «  hold$stk; 

IF  (GET$LE7EL  *  VALUESLEVEL)  THEN  VALUE$FLAG  *  FALSE; 
DEC $FLAG, FLAGS  (0 ), FLAGS  (1)  -  FALSE,' 

FLAGS (2)  -  TRUE,' 

COUNT, DEC$COUNT, DIGITS, FLAG ,FLOAT$VALUE .TYPE  =  0} 

/*  CHECK  FOR  EXCESSIVE  LENGTH  */ 

IF  FARC (0  )  >  30  THEN 

do; 

CALL  PRINT$ERROR( 'PC'); 

return; 

end; 

/*  SET  FLAG  BITS  AND  COUNT  LENGTH  */ 

i  -  i; 

DO  WHILE  I  <»  VARC(0)J 

IF  (CHAR  :*  VARC(I))  *  'A'  THEN 
CALL  INC$COUNT( ALPHA),* 

ELSE  IF  CHAR  «  'B'  THEN  CALL  INC$COUNT(A$EDIT) J 
ELSE  IF  CHAR  «  V  THEN 

do; 

DIGITS  »  DIGITS  ♦  i; 

CALL  INC$COUNT(NUK); 

end; 

ELSE  IF  CHAR  ■  'X'  THEN  CALL  INC$COUNT(A$N ) ; 
ELSE  IF  (CHAR  «  's')  AND  (COUNT-0)  THEN 
FLAG  -  FLAG  OR  SIGNED; 

ELSE  IF  (CHAR  ■  'V')  AND  (DEC$COUNT=0 )  THEN 
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do; 

FLAG  -  FLAG  OH  DHCt 
DEC$COUNT  *  COUNT? 

DECSFLAG  -  TRUE? 

end; 

ELSE  IF(CHAR  »  '/')  OR  (CHAR='0')  TEEN 
CALL  INC$COUNT(EDIT); 

ELSE  IF  CHAR  -  THEN  CALL  FLOAT$CHFCK ( 0) » 

ELSE  IF  SIGN (CHAR)  THEN  CALL  FLOATSCHECK (1 ) » 

ELSE  IF  (CHAR  -  '*  )  OR  (CHAR  =  'Z  )  TEEN 
CALL  FL0AT$CHECE(2); 

ELSE  IF  CHAR  *  THEN  CALL  INC$COUNT(NUM$EDIT ) ; 
ELSE  IF  (CHAR  »  AND  (DEC$COUNT=0 )  TEEN 

do; 

CALL  INC$COUNT(NUM$EDIT)*, 

DECSCOUNT  *  COUNT; 

DEC$FLAG  =  TRUE? 

end; 

ELSE  IF  ((CHAR  *  'C '  AND  FARC (I  ♦  1)  =  'R')  OR 
(CHAR  =  'D'  AND  ?ARC(I  +  1)='B'))  AND 
I  «  FARC (0)  -  1  AND  NOT  FLAGS (l)  THEN 

do; 

CALL  INC$COUNT(NUK$EDIT); 

char  =  farc ( i :=i  +  :); 

CALL  INC$COUNT(NUM$EDIT); 

IF  NOT  DEC$FLAG  THEN 

do; 

DEC$COUNT  «  FARC (0)  -  1? 
DEC$FLAG  =  TRUE; 

end; 

end; 

ELSE  IF  (CHAR  »  '(')  AND  (COUNTO0)  TEEN 

do; 

SAFE  *  FARC (I  -  1); 

REPITITIONS  *  0; 

DO  WHILE  (CHAR  :*  FARC(I  :=  I  ♦  1) )  <> 

IF  CHAR  <  '0'  OR  CHAR  >  ' 9 '  THEN 
CALL  PRINT$EFROR(  'P2'); 

REPITITIONS  «  SEL(REPITI TI0NS,3 )  ♦ 

SHL(REPITITIONS ,1 )  +  (CHAR  -  '0'); 

end; 

char  -  safe; 

IF  REPITITIONS  <>  0  THEN 

do; 

DO  J  •  1  TO  REPITITIONS  -  1? 

CALL  INC$COUNT(0); 

end; 

IF  SIGN(SAFE)  OR  SAFE  - 
OR  SAFE  -  'Z'  OR  SAFE  *  '9' 

OF  SAFE  -  THEN 
DIGITS  -  DIGITS  +  REPITITIONS  -  1? 
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ITT  ^  V 

COUNT  =  COUNT  -  i; 

end; 
else  do; 

CALL  PHINT$EBR0R('P3'); 

return; 

end; 
i  *  i  ♦  i; 

end;  /*  END  or  DO  while  i  <=  farc  */ 

IF  NOT  DEC$FLAG  AND  SIGN(VARC(I  -  1 ) )  THEN 

do; 

DEC$COUNT  -  VARC(0); 

DEC  $ FLAG  »  TRUE? 

end; 

/*  AT  THIS  POINT  THE  TYPE  CAN  BE  DETERMINED  */ 

I?  CHECK(NUM$MASK )  THEN  TYPE  »  NTYPE; 

ELSE  IF  CHECK(SNUM$MASK)  THEN  TYPE  =  SNTYPE; 

ELSE  IF  CHECK (ALPHA$MASK)  THEN  TYPE  =  A TYPE; 

ELSE  IF  CHECK (A$E$MASK )  THEN  TYPE  *  AETYPE; 

ELSE  IF  CHECK(A$N$MASK)  THEN  TYPE  *  ANTYPEJ 

ELSE  IF  CHECK(A$N$E$MASK)  AND  (((FLAG  AND  06E)  O  0) 

OR  ((FLAG  AND  09H)  <>  0)  OR  ((FLAG  AND  12H)  <>  0)) 

THEN  TYPE  «  ANETYPE; 

ELSE  IF  CHECK(NUM$ED$MASK)  THEN 

do; 

TYPE  «  NETYPEJ 
IF  FL0AT$7ALUE  <>  0  THEN 

do; 

i  *  i; 

DO  WHILE  FARC(I)  <>  FLOAT$FALUE; 
i  *  i  ♦  i; 

end; 

DO  I  «  I  ♦  1  TO  FLOATSPSIT; 

IF  FARC(I)  <>  FLOAT$VALUE  AND 
VARC(I)  <>  'B'  AND 
VARC(I)  <>  '/'  AND 
FARC(I)  <>  '0'  AND 
FARC (I)  <>  THEN 

do; 

CALL  PRINT$ERROR( 'P4'); 
i  »  float$psit; 
end; 

end; 

end; 

end; 

IF  TYPE  »  0  THEN  CALL  PRINT$ERROR( 'P5' ) ; 

ELSE  do; 

IF  (GST$TYPE  «  128)  TEEN 

CALL  SET?TYPE(128  +  TYPE); 

ELSE  CALL  SET$TYPE(TYPE ) ; 


CALL  SET$SLENGTH( COUNT  +  GET$S$LENGTH)t 
I?  (TTPE  AMD  64)  <>  0  THEM 

do; 

CALL  SET$ADDR2(TEMP  := 
PIC$ALLOCATE(COUNT))j 
CALL  START$INITIALIZE(TEMP, COUNT) » 

CALL  STRING$OUT( .BUFFER  +  1, COUNT); 

end; 

IE  DIGITS  >  16  THEN 

CALL  PRINT$ERR0R('P6'); 

IE  DEC$FLAG  THEN 

CALL  SET$DECIMAL( COUNT  -  DIC$COUNT); 

end; 

IE  (NOT  TRUNC$ELAG)  AND  ((TYPE  =  16)  OR  (TTPE  =  1?))  THEN 

do; 

DO  E  «  0  TO  HOLD$LIT(0); 

VARC(K)  -  HOLD$LIT(K); 

end; 

CALL  NUMSTRUNC; 

TRUNCSELAG  »  TRUE; 

end; 

END  picsanalizer; 

SET$EILE$ATTRIB :  PROC; 

DCL  TEMP  ADDRESS,  TTPE  BYTE; 

IE  CURSSTM  <>  VALUE(MPPl)  THEN 

do; 

TEMP  -  cur$stm; 

CUR$STM  *  VALCE(MPPl); 

STMBOL$ADDR(REL$ID)  -  TEMP; 

end; 

IF  NOT  (TEMP  :«  7ALUE(SP  -  1))  THEN 
CALL  PRINT$ERR0R( 'NF'); 

ELSE  do; 

IE  (TEMP  -  1)  OR  ( TEMP=5 )  THEN  TTPE-SECUENTIAL 
ELSE  IE  TEMP  *  15  THEN  TTPE»RAN DOM; 

ELSE  IF  TEMP  =  13  THEN  TTPE-SEQ ^RELATIVE; 

ELSE  do; 

CALL  PRINT$ERROR('IA'); 

TTPE  «  i; 

end; 

end; 

CALL  SET$TTPE(TTPE  ♦  UR $ MASK) ; 

END  set$eile$attrib; 

LOADUITERAL:  proc (lit$one) ; 

DCL  ( I  ,LIT$ONI,LIT$TTPE )  BYTE; 

LIT$TTPE  •  GET$TTPE; 

IE  LIT$TTPE  <>  0  THEN  EALUE$FLAG  -  FALSE; 

else  do; 


TALUESELAG  -  TRUE; 


tw** 


VALUE$LEVEL  =  GET$ LEVEL; 

end; 

IP  PENDING$ LITERAL  <>  0  THEN  CALL  PRINT$ERROR  ('LE')? 

ELSE  IP  ( LIT$ONE  *  0)  OR  ( LIT$TTPE  »  0)  THEN 

do; 

DO  I  »  0  TO  VARC(0); 

HOLD$LIT( I )  =  VARC(I); 

end; 

IP  (LIT$ONE  s  1)  AND  ( LIT$TTPE  =  0)  THEN 
TRUNC$FLAG  *  FALSE? 

end; 

ELSE  IP  (LIT$ONE  «  1)  AND  ( ( LIT$TYPE  >=  16)  AND 
(LITSTTPE  <»  21))  THEN 
CALL  NW$TRUNC; 

ELSE  IP  (LIT$ONE  *  1)  AND  (LITSTYPE  <>  0)  THEN 

do; 

CALL  PRINT$ERR0R('LV')? 

DO  I  *  0  TO  VARC(0); 

H0LD$LIT( I )  =  VARC(I); 

end; 

PEN  DING  $LITERAL  =  Zi 

end; 

end  load$literal; 
redef$test:  proc; 

DCL  SAVE$REDEF  BITE, 

(SAVE$REDEF$ONE,SAVE$RFDEF$TWO)  ADDRESS? 
SAVE$REDEP$ON E  *  REDEFSONE? 

SAVE$REDEF$TVO  *  REDEF$TWOJ 
REDEF$ONE  *  CUR$SYM? 

CALL  set$cor$stm; 

IP  (GTT$TTPE  >  OCCURS$TTPE)  AND  (GET$TBL$SIZE  <>  0)  THEN 
IF  (D$CNT  :«  D$CNT  -  1)  <>  0  THEN 
OCCURSSPTR  «  GET$PREV$ OCCURS ? 

ELSE  OCCURS $PTR  *  0? 

REDEF$TVO  -  CUR$SYM? 

SAVESREDEF  *  REDEP? 

REDEP  »  TRUE? 

call  redef$or$value; 

ID$STACK (ID$STAC1C$PTR)  *  0? 

ID$STACK$PTR  «  ID$STACK$PTR  -  1? 

REDEPSONE  -  SAVE$REDEF$ONE; 

REDEPSTVO  -  SAVE$REDEF$TWOJ 
REDEP  »  SAVE$REDEPJ 
END  REDEF$TEST? 

CHECmVLSPILES:  PROC; 

DCL  NEV$LEVEL  BITE? 

HOLD$STM ,CUR$STM  «  VALUE(MP  -  1)? 

CALL  SET$LEVEL(NEV$L1VEL  :»  VALUE(MP  -  2))J 
IP  NEWHEVEL  -  1  THEN 
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do; 

IT  ID$STACK (0 )  <>  0  THEN 

do; 

DO  WHILE  stackhevel  >  i; 

CALL  reduce$stack; 
end; 

DO  WHILE  ID$STACK$PTR  <>  0; 

CALL  SET$CUR$SYMJ 
CALL  REDEF$OR$TALDS; 

ID$STACK( ID$STACK$PTR  )  =  0J 
ID$STACK$PTR  *  ID$STACK$PTR  -  1J 

end; 

cur$stm  =  hold$sym; 

CALL  SET$REDEF(ID$STACK(0),VALUF(MP  -  D); 
VALUE (MP)  ■  l;  /*  SET  REDEFINE  FLAG  */ 

end; 

end; 

ELSE  DO  WHILE  STACX$LEVEL  >=  NEW$LEVEL» 

call  reduce$stack; 
end; 

END  CHECK$LVL$FILES; 

CHECK $LVL$ WORK:  PROC; 

DCL  NEW$LEVEL  BYTE, 

S AVE$SYM$LVL  BYTE, 

STACK$REDUCED  BYTE, 

SAVE$REDEF  BYTE, 

REDEF$FLAG  BYTE,  /*NXT  LVL  IS  A  REDEFINES*/ 

save$syk  address; 

SET$VALUE$CLAUSE :  PROCJ 
SAVE$REDEF  *  REEEF; 

REDEF  -  FALSE; 

call  set$cur$sym; 
call  redef$or$value; 

REDEF  *  SAVE$REDEF; 
cur$sym  =  H0LD$SYMJ 
end  set$value$clause; 

trunc$flag  -  true; 

STACK$REDUCED  -  FALSE; 

HOLD$SYM,CUR$SYM  «  VALUE (MP  -  i); 

CALL  SET$ LEVEL (NEW$LEVEL  :»  VALUE(KP  -  2)); 
REDEF$FLAG  -  VALUE(MP);  /*SET  IN  PROD  #64*/ 

IF  NEW$LEVEL  «  1  OR  NEW$LEVEL  *  7?  THEN 

do; 

IF  STACK$LEVEL  ■  77  THEN 

CALL  end$of$record; 

ELSE 

do; 

DO  WHILE  STACK$LEVEL  >  1 


AMD  ID$STACK( IDSSTACKSPTR)  <>  0; 

SAVESSTM, CURSSTM  »  IDSSTACK (IDSSTACKSPTR  -  1); 
SAVE$SYM$LVL  =  GET$LEVFL; 

IF  SAVE$STM$LVL  *  STACKSLEVEL  THEM 

do; 

cursstm  «  savesstm; 

CALL  REDEFSTEST? 

end; 

ELSE  IF  STACKSLEVEL  >  1  THEN 

do; 

call  reducesstack; 

IF  VALUESFLAG 

AND  (VALUESLEVEL  *  STACKSLEVEL)  THEN 

do; 

VALUESFLAG  ■  FALSE; 

CALL  SETS VALUES CLAUSE? 
end; 
end; 

end;/#  do  while  loop  */ 

IF  STACKSLEVEL  *  1  AND  IDSSTACKSPTR  <>  0  T*EN 

do; 

CURS STM  *  I D$ STACK ( IDSSTACKSPTR  -  1); 

CALL  redefstest; 
end; 

IF  REDEFSFLAG  =  0 

AND  IDSSTACK(IDSSTACKSPTR)  <>  0  THEN 

do; 

call  endsofsrecord; 

REDEF  *  FALSE; 

end; 

IF  (REDEFSFLAG  *  1) 

AND  (IDSSTACK (IDSSTACKSPTR)  =  REDFFSONE) 

THEN  CALL  SET$VALUE$CLAUSE? 

end; 

end; 

ELSE  IF  STACKLEVEL  *  77  THEN  CALL  PRINT$ERROR( 'L7 ' ) ; 

ELSE  IF  STACKSLFVEL  >*  NEWSLEVEL  THEN 

do; 

IF  (STACKSLEVEL  «  NEWSLEVEL)  AND  (REDEFSFLAG  =1)  AND 
(IDSSTACK(IDSSTACKSPTR)  =  REDEFSONE)  THEN 

call  setsvaluesclause; 

DO  WHILE  NOT  STACK$REDUCED; 

SAVESSTM , CURSSTM  *  IDSSTACK( IDSSTACKSPTR  -  1); 

savesstms lvl  »  getslevel; 

IF  SAVESSTMSLVL  *  STACKSLEVEL  THEN 

do; 

CURSSTM  «  SAVESSTM; 

CALL  redefstest; 
end; 

ELSE  IF  (STACKSLEVEL  >*  NEWSLEVEL) 

AND  (REDEFSFLAG  -  0)  THEN 


do; 

call  reduce$stack; 

IF  7ALUE$FLAG  AND  (7ALUE$LE7EL  =  STACK$LE7EL) 
AND  (7ALUE$LE7EL  =  NEV$LE7EL)  TEEN 

do; 

7ALUE$FLAG  -  FALSE? 

CALL  set$7alue$clause; 
end; 

IF  STACK$LE7EL<NEV$LE7EL  THEN 
STACK$REDUCED  =  TRUE; 

end; 

ELSE  IF  (STACK$LE7EL  >»  NEW$LE7EL) 

AND  (REDEF$FLAG  *  1)  THEN 

do; 

IF  STACK$LE7EL>NEW$L£7EL  THEN 
CALL  reduce$stack; 

IF  7ALUE$FLAG 

AND  (7ALUE$LE7EL  3  STACK$LE7EL)  THEN 

do; 

7ALUE$FLAG  *  FALSE? 

CALL  SET$7ALUE$CLAUSE; 

end; 

IF  STACK$LE7EL  <«  NEV$LE7EL  THEN 
STACK $REDUCED  3  TRUE? 

end; 

end;  /*  DO  WHILE  LOOP  */ 

end; 

cur$stm  -  holdsstm; 
end  check$lyl$work; 

CODE$GEN:  PROC (PRODUCTION )  ? 

DCL  PRODUCTION  BITE, 

LIT$TTPE  BYTE? 

IF  PRINT* PROD  THEN 
DO? 

call  crlf; 

CALL  PRINTCHAR(POUND)? 

CALL  PRIN T$N UMBER ( PRODUCTION ) ? 

end; 

DO  CASE  production; 

/*  PRODUCTIONS*/ 

/*  CASE  0  NOT  USED  */ 

/*  1  <PROGRAM>  <ID  -  DI7>  <E  -  DIY>  <D  -  DI7>  */ 

/*  1  PROCEDURE  */ 

DO? 

COMPILING  -  FALSE? 

call  displat$line; 
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DEBUGGI 

/* 

18 

• 

9 

/* 

/* 

19 

/* 

19 

• 

9 

/* 
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20 

• 

9 

/* 

/* 

21 

• 

» 

/* 

/* 

22 

/* 

22 

2  <ID  -  DIV>  ::=  IDENTIFICATION  DIVISION  . 

PROGRAM-ID  . 

2  <COMMENT>  .  <ID-LIST> 

/*  NO  ACTION  REQUIRED  V 
3  <ID-LIST>  s :=  <AUTH>  <INS>  <DATE>  <SEC> 
/*  NO  ACTION  REQUIRED  */ 

4  <AUTH>  AUTHOR  .  <COMMENT>  . 

/*  NO  ACTION  REQUIRED  */ 

5  \!  <EMPTT> 

/*  NO  ACTION  REQUIRED  */ 

6  <INS>  INSTALLATION  .  <COMMENT>  . 


<DATE> 


\ !  <EMPTT> 

I  REQUIRED  */ 

DATE  -  WRITTEN  .  <COMMEN' 


<COMMENT> 


\ !  <EMPTT> 

10  ACTION  REQUIRED  */ 
<SEC>  : i«  SECURITY  . 
10  ACTION  REQUIRED  */ 
\!  <EMPTY> 

10  ACTION  REQUIRED  */ 
<C0MMENT>  <INPUT> 


3  \!  <C0MMENT>  <INPUT> 

/*  NO  ACTION  REQUIRED  */ 

4  <E  -  DIV>  ENVIRONMENT  DIVISION  . 

CONFIGURATION  SECTION 

4  <SRC  -  OEJ>  <1  -  0> 

/*  NO  ACTION  REQUIRED  V 

5  \ !  <EMPTT> 


<SRC  -  OBJ>  SOURCE  -  COMPUTER 

<DEBUG>  . 

OBJECT  -  COMPUTER  . 


.  <COMMENT>  */ 
V 

<’COMMENT>  .  */ 


<DEBUG>  DEBUGGING  MODE 
•  =  TRUE?  /*  SETS  A  SCANNER  TOGGLE  */ 
\l  <EMPTY> 


<I-0>  INPUT-OUTPUT  SECTION 


FILE-CONTROL  */ 
T>  <IC>  */ 


.  <FILE  -  CONTROL  -  LIST>  <IC> 

10  ACTION  REQUIRED  */ 

\ !  <EMPTY> 

10  ACTION  REQUIRED  */ 

<FILE-CONTROL-LIST>  :  <FILE-CONTROL-ENTP.Y> 


/*  NO  ACTION  REQUIRED  */ 


\I  <FILE-CONTROL-LIST> 
<FILE-CONTROL-ENTRT> 
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23  <F ILE-CON TROL-EN TRY >  SELECT  <ID>  V 

<ATTRIBUTE-LIST>  .  */ 

CALL  SET$FILE$ATTRIB> 

24  <ATTR IBUTE-L I S T>  ::  =  <0NE-ATTRIB>  */ 

J  /*  NO  ACTION  REQUIRED  V 

25  \ !  <ATTR IBUTE-L I ST>  */ 

<0NE-ATTRI3>  */ 

VALUE (MP)  =  VALUE(SP)  OR  VALUE  (MP ) ; 

26  <ONE-ATTRIB>  ORGANIZATION  <ORG-TTPE>  */ 

VALUE(MP)  *  VALUE (SP)| 

27  \ !  ACCESS  <ACC-TYPE>  <RELATIVE>  */ 

VALUE(MP)  =  VALUE (MPP1 )  OR  VALUE(SP)? 

29  \J  ASSIGN  <INPUT>  */ 

CALL  build$fcb; 

29  <ORG-TYPE>  SEQUENTIAL  */ 

?  /*  NO  ACTION  REQUIRED  -  DEFAULT  */ 

30  \ !  RELATIVE  */ 

CALL  0R$VALUE(SP,4),‘ 

31  \1  INDEXED  */ 

CALL  PRINT$ERR0R('NI'),* 

32  <ACC-TYPE>  SEQUENTIAL  */ 

J  /*  NO  ACTION  REQUIRED  -  DEFAULT  */ 

33  \!  RANDOM  */ 

call  or$value(sp,2); 

34  <RELATIVE>  RELATIVE  <ID>  */ 

do; 

CALL  0R$VALUE(MP,8); 

CURSYM.  =  VALUE(SP); 

CALL  SET$TYPE<REL$KEY$UR); 

end; 


/* 

35 

\!  <EMPTY> 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  -  DEFAULT  */ 

/* 

36 

<IC>  :;=  I-O-CONTROL  .  <SAME-LIST> 

*/ 

• 

f 

/* 

NO  ACTION  REQUIRED  */ 

/* 

37 

\!  <EMPTY> 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

38 

<SAME  -  LIST>  :*.*  <SAME  -  ELEMEN T> 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

39 

M  <SAME  -  LIST>  <S  AME  -  ELEMENT^/ 

• 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

40 

<SAME-ELEMENT>  SAME  <ID-STRING>  . 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

41 

<ID-STRING>  s : *  <ID> 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

42 

\ !  <ID“STRING>  <ID> 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

43 

<D-DIV>  : s=  DATA  DIVISION  .  <FILE-SFCTION> 

*/ 

/* 

<WORK> 

*/ 

/* 

43 

<LINK > 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

44 

<FILE-SECTION>  FILE  SECTION  .  <FILE-LIST> 

*/ 
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FILE$SEC$END  *  TRUE# 

45  \ !  <EMPTT> 

FILE$S EC$END  »  TRUE? 

46  <?ILE-LIST>  <FILES> 

J  /*  NO  ACTION  REQUIRED  */ 

4?  \ !  <FIIE-LIST>  <FILES> 

;  /*  NO  ACTION  REQUIRED  */ 

46  <FIIES>  FD  <ID>  <FILE-CONTROL>  . 

48  <RECORD-DESCRIPTION> 

do; 

DO  WHILE  STACK$LEVEL  >  15 
CALL  REDUCE$STACS; 

end; 

call  end$of$record; 

REDEF  =  FALSE; 

end; 

49  <FILE-CONTROL>  <FILE-LIST> 

CALL  SET$IO$ADLRS; 

50  \ !  <EKPTT> 

CALL  SET$IO$ADDRS; 

51  <FILE-LIST>  <FILE-ELEMENT> 

;  /*  NO  ACTION  REQUIRED  */ 

52  \!  <FILE-LIST>  <FILE-ELEMFNT> 

;  /*  NO  ACTION  REQUIRED  */ 

53  <FILE-ELEMENT>  =  BLOCK  <INTEGFR>  RECORDS 

;  /*  NO  ACTION  REQUIRED  -  FILES  NEVER  BLOCKED  */ 

54  \ !  RECORD  <REC-COUNT> 

CALL  SET$SLENGTH( VALUE(SP) ); 

55  \ I  LABEL  RECORDS  STANDARD 

;  /*  NO  ACTION  REQUIRED*/ 

56  \1  LABEL  RECORDS  OMITTED 

i  /*  NO  ACTION  REQUIRED*/ 

57  \!  VALUE  OF  <ID  -  STRING> 

;  /*  NO  ACTION  REQUIRED  */ 

58  <REC-COUNT>  <INTEGER> 

;  /*  NO  ACTION  REQUIRED  -  VALUE(SP)  CORRECT  */ 

59  \!  <INTEGER>  TO  <IN  TEGER> 

do; 

VALUE(MP)  =  VALUE(SP)?  /*  VARIABLE  LENGTH  */ 

CALL  SET$TTPE(VAP.IABLE$LENG);  /*  SET  TO  VARIABLE  */ 

end; 

60  <WORX>  WORKING-STORAGE  SECTION  . 

60  <RECORD-DESCRIPTION> 

do; 

IF  STACK$ LEVEL 077  THEN 

do; 

DO  WHILE  STACKHEVEL  >  1} 

CUR$STM  »  ID$STACK(ID$STACK$PTR  -  1); 

IF  GETHEVEL  *  STACKHEVEL  THEN 
CALL  redef$test; 

ELSE  IF  STACK$LEVEL  >  1  THEN 
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CALL  reduce$stack; 

end; 

IE  STACK$LEVEL  *  1  AND  ID$STACK$P.TB  <>  0  THEN 

do; 

CUR$SYM  »  ID$STACK(ID$S?ACK$PTR  -  1)» 

IE  BEDEE  TEEN  CALL  REDEF$TEST; 

end; 

end; 

call  end$of$record; 


end  ; 


/* 

61 

\!  <EMPTY> 

V 

• 

f 

/* 

NO  ACTION  REQUIRED  ♦/ 

/* 

62 

<LINK>  LINKAGE  SECTION  . 

*/ 

/* 

62 

<RECORD-DESCRIPTION> 

*/ 

• 

t 

/* 

NO  ACTION  REQUIRED  «*/ 

/* 

63 

\1  <EMPTT> 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED  V 

/* 

64 

<RECORD“DESCRIPTION>  =  <LEVEL-ENTRY> 

*/ 

« 

9 

/* 

NO  ACTION  REQUIRED  */ 

/* 

65 

\!  <RECORD-DESCRIPTION> 

*/ 

/* 

65 

<LEVEL-BNTRY> 

*/ 

• 

9 

/* 

NO  ACTION  REQUIRED*/ 

/* 

66 

<LEVEL-ENTRY>  <INTEGEB>  <DATA-ID> 

*/ 

/* 

66 

<REDEFINES>  <DATA-TYPE>  . 

*/ 

do; 

call  loadhevel; 

IE  (PENDING$LITERAL  <>  0)  AND  (NOT  VALUE$FLAG)  THEN 
PENDING$LIT$ID  =  ID$STACK$PTR ; 

end; 

/*  67  <DATA-ID>  <ID>  */ 

IE  NOT  UI$FLAG  TEEN 

do; 

IF  GET$TTPE  *  REL$KEY$UR  TEEN 
CALL  SET$TTPE(REL$KET); 

ELSE 

CALL  PR IN T$ ERROR ( 'DD' ) J 

end; 

/»  68  \ I  FILLER  */ 

do; 

CUR$STM ,  YALUE(SP)  *  next$stm; 

CALL  BUILD$STM3OL(0); 

end; 

/*  69  <REDEFINES>  REDEFINES  <ID>  */ 

do; 

IF  UISFLAG  THEN 

CALL  PRINT$ERROR( 'UD')J 
CALL  SET$REDEF(7ALUE(SP) ,VALUE(SP  -  2)); 

VALUE (MP )  -  l;  /*  SET  REDEFINE  FLAG  ON  */ 

IF  NOT  FILE$SEC$END  THEN 
CALL  PRINT$ERR0R('R3'); 

CALL  CEECK$LVL$WORKr 


"71vrrT 
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end; 

/*  70  \!  <EMPTY>  *7 

do; 

IF  NOT  FILE$SEC$END  THEN 
CALL  CHECK$LVL$FILES; 

ELSE  CALL  CHECK$L?L$¥ORK » 

end; 

/*  71  <DATA-TTPE>  =  <PROP-LIST>  »/ 

5  /*  NO  ACTION  REQUIRED  */ 

/*  72  \ !  <EMPTT>  */ 

;  /♦  NO  ACTION  REQUIRED  */ 

/*  73  <PROP-LIST>  : :=  <DATA-ELEMENT>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  74  \l  <PR0P-LIST>  <DATA-FLEMENT>  V 

J  /*  NO  ACTION  REQUIRED  */ 

/*  75  <DATA-ELEMENT>  PIC  <INPUT>  */ 

CALL  PIC$ANALIZEP; 

/*  76  \!  USAGE  COMP  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

/*  77  \l  USAGE  COMP-3  */ 

CALL  SET$TYPE(COMP) ; 

/*  78  \!  USAGE  COMPUTATIONAL  */ 

;  /*  NO  ACTION  REQUIRED-NOT IMPLEMENTED  */ 

/*  79  \ !  USAGE  DISPLAY  */ 

;  /*  NO  ACTION  REQUIRED  -  DEFAULT  */ 

/*  80  \1  SIGN  LEADING  <SEPARATE>  */ 

CALL  SET$SIGN(17)J 

/*  81  \r  SIGN  TRAILING  <SEPARATE>  */ 

CALL  SST$SIGN(18); 

/*  62  \ !  OCCURS  <INTEGER>  INTFXED  */ 

/*  82  <ID>  */ 

;  /*  NO  ACTION  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

/*  83  \!  OCCURS  <INTEGER>  */ 

do; 

CALL  SET$T3L$SIZE(VALUE(SP)  ); 

D$CNT  ■  D$CNT  +  1J 
CALL  PROCESS$OCCURS; 

occurs $ptr  «  cur$stm; 

IF  (TEMP$T¥0  :«  GET$LEVEL)*1  OR  TEMP$T¥0=77  THEN 
CALL  PRINT$ERROR( 'OL') ; 

end; 

/*  84  \ !  SYNC  <DIRECTION>  */ 

;  /*  NO  ACTION  REQUIRED  -  BYTE  MACHINE  */ 

/*  85  \!  VALUE  <LITERAL>  */ 

IF  NOT  FILE$SEC$END  THEN 

do; 

CALL  PRINT$ERROR( '?E'); 

PENDING$LITERAL  »  di 

end; 

/*  86  <DIRECTION>  LEFT  V 

J  /*  NO  ACTION  REQUIRED  */ 
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/*  87  \!  SIGHT  */ 

?  /*  HO  ACTION  REQUIRED  V 

/*  £8  \ !  < EMPTY >  V 

J  /*  HO  ACTION  REQUIRED  */ 

/*  89  <SEPARATE>  :.*»  SEPARATE  */ 

VALUE(SP)  »  2} 

/*  90  \!  <EMPTY>  */ 

,*  /*  HO  ACTION  REQUIRED  */ 

/*  91  <LITERAL>  <INPUT>  */ 

ro; 

I?  ( ( LIT$TIPE  :«  GET$TYPE)  <  16)  OR 
(LIT$TYPE  >  21)  THEN 

do; 

CALL  PRINT$ERROR( 'NV'); 

call  loaduiterauo); 

PENDING$LITERAL  *  2; 

end; 
else  do; 

call  load$literal(i); 

PENDINGUITERAL  =  15 

end; 

end; 

/*  92  \ !  <LIT>  */ 

do; 

CALL  LOAD$LITERAL(0); 

PEND ING$LI TEFAL  *  2t 

end; 

/*  93  \ I  ZERO  */ 

pendinghiteral  *  3; 

/*  94  \  I  SPACE  V 

PENDING$ LITERAL  =  4; 

/*  95  \!  QUOTE  */ 

PENDING$ LITERAL  =  5; 

/*  96  <INTEGER>  <INPUT>  */ 

CALL  CONVERT*  INTEGER,* 

/*  97  <ID>  <INPUT>  */ 

do; 

VALUE(SP)  »  MATCH;  t*  STORE  SYMBOL  TABLE  POINTERS  V 
IF  FILE$DESC$FLAG  THEN 

do; 

FILE$DESC$FLAG  =  FALSE; 

IF  UI$FLAG  THEN 

CALL  PRINT$ERROR('UD'); 

ELSE 

IF  GIT$TYPI>UR$MASK  THEN 

CALL  5ET$TYPE(GET$TYPE  -  UR$MASK ) * 

ELSE 

CALL  PRINT$ERR0R( 'DD')i 

end; 

end; 

end;  /*  END  OF  CASE  STATEMENT  V 
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END  code$gen; 


GETIN1:  PROC  BITE? 

RETORN  INDEX1 (STATE)? 

END  GETINi; 

GETIN2;  PROC  BTTE; 

RETURN  INDEX2( STATE); 

END  GETIN2; 

INCSP:  PROC; 

IE  (SP  :=  SP  +  1)  >=  PSTACKSIZE  THEN 
CALL  EATAL$ERROR('SO'); 

VALUE(SP)  =  0;  /*  CLEAR  VALUE  STACK  */ 

END  INCSP; 

LOOKAHEAD:  PROC J 
IE  NOLOOK  THEN 

do; 

CALL  scanner; 

IF  TOKEN  *  2  THEN  FILE$DESC$FLAG  =  TRUE; 

NOLOOK  =  false; 

IF  PRINT$TOKEN  THEN 

do; 

call  crlf; 

CALL  PRINT$NUMBER (TOKEN); 

CALL  PRINT$CHAR( '  '); 

CALL  PRINT$ACCUKJ 

end; 

end; 

end  lookahead; 

NO$CONFLICT :  PROC  (CSTATE)  BITE; 

DCL  ( CSTATE, I ,J,K)  BITE; 

J  »  INDEXK CSTATE); 

K  *  J  ♦  I NDEX2 (CSTATE)  -  i; 

DO  I  *  J  TO  k; 

IF  READl(I)  »  TOKEN  THEN  RETURN  TRUE.* 

end; 

RETURN  FALSE; 

end  nosconflict; 

RECOVER:  PROC  BYTE; 

DCL  (TSP ,  RSTATE)  BYTE? 

DO  forever; 

TSP  »  SP? 

DO  WHILE  TSP  <>  255; 

IF  NO$CON FLIC T( RSTATE  :«  STATESTACK(TSP) )  THEN 
DOJ  /*  STATE  WILL  READ  TOKEN  */ 

IF  SPOTSP  THEN  SP  *  TSP  -  l; 

RETURN  RSTATE; 


end; 

tsp  »  tsp  -  1; 
end; 

call  scanner;  /*  try  another  token  */ 

end; 

end  recover; 

END$PASS:  PROC? 

/*  THIS  PROCEDURE  STORES  THE  INFORMATION  REQUIRED  BT 
PASS2  IN  LOCATIONS  ABOVE  THE  SYMBOL  TABLE.  THE 
FOLLOWING  INFORMATION  IS  STORED:  INPUT  BUFFER  POINTER, 
OUTPUT  FILE  CONTROL  BLOCK,  COMPILER  TOGGLES  */ 

CALL  BYTE$OUT(SCt); 

CALL  ADDR$OUT(NEXT$AVAILABLE); 

CALL  MOVE (.DISPLAY* 1),.LINE$CTR(0),5); 

OUTPUT$PTR  «  OUTPUT$PTR  -  .OUTPUT$BUFF; 

LIST$PTR  »  LIST$PTR  -  .LIST$BUFF,‘ 

CALL  MOVS(. DEBUGGING, MAX$MEMORY  -  PASS1$LEN,PASS1$LEN) ; 

L:  GO  TO  L;  /*  PATCH  TO  “JMP  0B000H"  */ 

END  end$pass; 

/*•***  PROGRAM  EXECUTION  STARTS  HERE  **•**/ 

CALL  MOVE( IN ITIAL$POS ,MAX$MEMORY ,RDR$LENGTH) J 
CALL  INIT$SCANNER! 

CALL  INIT$SYMBOL; 


/*  * 


parser  *  *  * 


DO  WHILE  compiling; 

IF  STATE  <=  MAXRNO  THEN  /*  READ  STATE  */ 

do; 

CALL  INCSPI 

STATES TACK(SP)  *  STATE;  /*  SAVE  CURRENT  STATE  */ 
CALL  LOOKAHEAD; 

I  »  GETINi; 

J  -  I  +  GETIN2  -  l; 

DO  I  »  I  TO  j; 

IF  READl(I)  *  TOKEN  THEN 

do; 

/*  COPY  THE  ACCUMULATOR  IF  IT  IS  AN 
INPUT  STRING.  IF  IT  IS  A  RESERVED 
WORD  IT  DOES  NOT  NEED  TO  BE  COPIED.*/ 
IF  (TOKEN  -  INPUT$STR) 

OR  (TOKEN  =  LITERAL)  THEN 
DO  K  «  0  TO  ACCUM (0) ; 

VARC(K)  =  ACCUM(K); 

end; 

STATE  =  READ2(I); 

NOLOOK  *  true; 
i  «  j; 
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end; 

ELSE  IF  I  =  J  THEN 

do; 

CALL  PRINT$ERROR('NP'){ 

CALL  PRINT ( . (  '  ERROR  NEAR  $')); 

call  print$accum; 

IP  (STATE  :*  RECOVER)  =  0  THEN 
COMPILING  =  false; 

end; 

end;  /*  do  i  =  i  to  j;  */ 

END;  /*  END  OP  READ  STATE  */ 

ELSE  IP  STATE  >  MAXPNO  THEN  /*  APPLY  PRODUCTION  STATE  */ 

do; 

MP  «  SP  -  GETIN2; 

mppi  »  mp  ♦  1; 

CALL  CODE$GEN (STATE  -  MAXPNO); 

SP  *  MPJ 
I  =  GETINi; 

J  =  statestack (sp) ; 

DO  WHILE  (X  :«  APPLYl(I))  <>  0  AND  J  O  X? 

I  -  I  +  1; 

end; 

IP  (K  :=  APPLY2( I) )  =  0  THEN  COMPILING  =  FALSE? 
STATE  »  K? 

end; 

ELSE  IF  STATE  <=  MAXLNO  THEN  /’•LOOKAHEAD  STATE*/ 

do; 

I  =  GETINI? 

CALL  lookahead; 

do  WHILE  (K  :*  LOOKl(I))  <>  0  AND  TOKEN  <>  K? 
1*1*1? 

end; 

STATE  *  L00K2(I); 

end; 

ELSE 

do;  /*push  states*/ 

CALL  INCSP; 

STATESTACK (SP)  *  GETIN2? 

STATE  «  GETINI? 

end; 

END?  /*  DO  WHILE  COMPILING  */ 

CALL  END$PASS? 

END? 
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COMPUTES  LISTING  EOS  MODULE  PAST  TWO  NPS  MICBO-COBOL 


$  TITLE('NPS  MICRO-COBOL  COMPILER  PART  2')  PAGEVIDTH(80) 
PAGEWIDTH{60) 

PART2:  DOJ  /*  MODULE  NAME  */ 

/*  COBOL  COMPILER  -  PART  2  */ 

/*  MODULE  LOCATED  AT  103S  */ 

/*  GLOBAL  DECLARATIONS  AND  LITERALS  */ 


DCL 

LI  TER ALL! 

'DECLARE', 

LIT 

LITERALLY 

'LITERALLY'? 

FALSE 

LIT 

'0', 

ALPHA$LIT$FLAG  BITE 

INITIAL(FALSE), 

CR 

LIT 

'13', 

ERROR 

BITE 

INITIAL( FALSE) , 

FOREYER 

LIT 

'WHILE  TRUE', 

IF$FLAG 

BITE 

INITIAL(FALSE), 

LF 

LIT 

'10'. 

MAX$MEMORT 

ADDRESS 

INITIAL(031007) 

PASS1$LEN 

ADDRESS 

INITIAL(353), 

PASSl$TOP 

ADDRESS 

INITIAL( 0B000H) 

POUND 

LIT 

'23H', 

PROC 

LIT 

'PROCEDURE', 

QUOTE 

LIT 

'27H', 

TRUE 

LIT 

'i'; 

MAZLNO  LIT 

'179',  /*  MAX 

LOOK  COUNT  */ 

MAXPNO  LIT 

'196',  /*  MAX 

PUSH  COUNT  */ 

MAXRNO  LIT 

'136',  /*  MAX 

READ  COUNT  */ 

MAXSNO  LIT 

'345',  /*  MAX 

STATE  COUNT  */ 

STARTS  LIT  'l',  /*  START  STATE  */ 

ENDC  LIT  '22',  /*  END  */ 

FOPC  LIT  '19',  /*  EO?  V 

PROCC  LIT  '60',  /*  PROCEDURE  */ 

TERMNO  LIT  '81';  /*  TERMINAL  COUNT  */ 

DCL  READ1(»)  BITE 

DATA(0, 80, 14, 15, 20, 26, 28, 32, 34 ,36 ,38, 44, 45, 54 
,65,69,70,75,77,63,3,41,63,63,3,4,7,41,63,78, 
,42,49,50,63,76,23,48,61,47,25,41,42,49,50,63 
, 63 , 74, 1, 72, 3, 43, 56, 39, 2, 10, 11, 31, 46, 66, 6e, 81 
,28,32,33,34,36,38,44,54,55,57,58,64,65,69,70 
,30,13,51 ,5, 8, 41, 52, 63, 73,78,?1, 6, 21,11, 71, 60 
.1,27,59,59,18,24,18,41,60,63,12,22,67,14,20, 
,38,44,54,55,57,58,64,65,69,70,75,77.29,41,60 
,1,14,15,20,26,28,32,34,36,38,44,54,55,57.58, 


IS  */ 


,55,57,58,64 

41,63,42,41 

,16,1,53,35 

,14,15,20,26 

,75,77,13,13 

,60,71,60,71 

26, 2e, 32, 34 

,63,29,67,1 

64,65,69,70 


,75, 77 , 4, 7, 4, 6, 7, 14, 15, 17, 20, 26, ?8, 32, 33, 34, 36, 38, 44 .54 
,55,57,58,64,65,69,70,75,77,17,63,79,52,19,63,37,40,41,42 
,49,50,63 ,6,9,3,41,42,49,50,63,0,0); 

DCL  L00K1  (*)  BYTE 

DATA{0, 19 ,63, 0,63, 0,3, 0,53, 0,63, 79, 0,63, 0,43, 56, 0,3, 0,39 
,0,5,8,0,5,8,0,5,8,0,5,8,0,5,8,0,41 ,52,63,73,0,21,0,21 ,0, 
,71,0,71,0,60,71,0,60,71,0,71,0,71,0,71,0,71,0,71,0,2,10 
,11,24,31,46,66,68,81,0,23,48,61,0,12,0,12.0,12,0.53,0,67 
,0,63,0,63,0,27,59,0,4,7,0,63,0,17,0,63,0,37,0,40,41 ,42 
,49,50,63.0,19,63,0); 

DCL  APPLY1  (*)  BITE 

DATA(0, 0,113, 0,19, 0,0, 128, 0,0, 134, 0,71, 105, 11 0,119, 123 

,130,0,0,0,0,133,0,0,127,0,0,0,0,0,71,119.123,0,71,0.0 

,105,110,130,0,0,0,6,0,7,3,10,11,0,9,12,0,15,0,105,110 

,130,0,41 ,0,4, 21, 0,25, 0,0,0, 0,88, 90  ,91,92,93,94,95,96,0.0 

,0,0,0,0,114,0,0,0,0,0,102,0,16,17,22,23,26,30,47,46.49 

,50,51,52,57,66,0,0,2,16,17,19,22,23,27,28,30,34,37,39,40 

,42,43 ,44 ,45 ,47, 48, 49, 50, 51, 52, 54, 55, 57, 62, 66, 11 5, 116, 122 

,125,126,128,132,133,0,6,7,8,9,10,11,12,14,15,18,24,29.46 

,59,60,81,103,111,0,16,17,22,23,28,30,44,47,48,49,50,51 

,52,57,66,0,0,0,36,0.0,31,53,104,131,0,0,0,0); 

DCL  READ2  (*)  ADDRESS 

DATA(0, 63 ,19, 345, 24, 26, 138 ,31 ,33,34,36,39,40,43,44,45,45 
,52,53 ,54,55,59,60,331,6,329,139,332,6,7,10,329.139,218 
329,139,333,329,334,336,335,139,249,322.320,321,313,301 
339,334,336,335,338,20,206,42,319,325,140,137,56,5,317 
,319,37,296,295,297,293,294,292,287,288,19,345,24,26,138 
,31,32,33 ,34,36,39,43,44,45,46,52,53,54,55.59.60,18,16,30 
, 17,234,9,12,329,41 , 139,57 ,61,25 ,286,25,14,298,49 ,50 ,298 
,51,298,2,250,247,246,23,290,22,329,47,139,15,303.312,19 
24, 26, 138 ,31, 33. 36, 39, 43,44, 45 ,46 ,52, 53, 54, 55, 59. 60, 2e 
,329,48,139,29,312,207,208,19,345,24,26,138,31,33,34,36 
,39,43,44 ,45,46,52.53,54,55,59,60,8,11,8,276,11.19,345,21 
,24,26,138,31,32,33,34,36,39,43,44,45,46.52,53,54,55,59 
,60,21 ,326,62 ,41 , 197,326 ,35 ,38 ,329,334,336,335,139,330 , 13 
,4,329,334,336,335,139,0,0); 

DCL  L00K2  (*)  ADDRESS 

DATA(0, 204, 204, 3, 27, 180, 326, 327 ,58, 181, 200, 20e, 220, 66, 182 
,67,67,183,68,324,69,184,76,76,265,77,77,268,78,78,269.79 
, 79, 266, 80, 80, 267, 81, 81, 81, 81, 185 ,83, 2e0, 85, 281, 87, 166, 68 
,187,90,90,188,91,91,189,92,190,93,191 ,94,192,95,193,96 
,194,195,195,195,101,195,195,195,195,195,284,102,102.102 
,223,106,270,107,271,108,272,113,196,114,216,115,230,116 
,231 ,246,248,119,120, 120,260,122 ,215,124,238, 125 , 198 ,129 
,213,131,131,131,131,131,131,217,205,205,134); 
not  i  pvt  T9  f*) 

DATA{0, 0,214, 97, 126, 176, 128, 203, 202, 179, 118, 117, 306, 244 
,245,307,306,243,209,174,178,164,171,170,224,236,235  ,112 
,  127 ,72 ,240 , 308 , 309 ,306,210,99,98,71,213,213,213, 177 1 1 03 
,111,121,173,147,149,148,150,146,166,167,165,274,273,216 
,216,216,169,175,123,84,153,152,283,282,285,70,104,252 
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Ifittii  in  rtf 


,253,256,258,259,254,255,257,251,225,110,211,172.151,105 
, 302, 130, 279, 82, 314, 133, 132, e9, 157, 154, 222, 158, 156, 155 
,159,160,161,162,86,239,304,212,318,64,144,144,141,144 
,144,342,144,144,344,310,226,142,200,143,144,277,144,144 
,144,144,144,144,145,278,144,221,144,233,233,227,201,201 
,64,232,232,65,275,275,275,275,275,275,275,275,275,242 
,261,241 ,73 ,74,263,75,262,264,340 ,323,323,323,323,323,323 
, 323 ,323,323, 323 , 323 , 323 , 323 , 323 , 323 , 32e , 135 , 1 66 , 337 , 341 
,300,100,228,289,229,163,219,109,136); 

DCL  INDEX1  (*)  ADDRESS 

DATA (0,1, 203, 2, 217, 23, 28, 24, 24, 24, 24, 24, 24, 27, 28, 24, 203 
,203,34,203,33,217,203,203,34,217,36,203,203,34,203,37,42 
,43 ,203 ,46,47,203 , 53 , 203 ,203,217, 203 ,203,203, 203  ,34,203 
,203,203,203,203,203,37,203,203,54,203,55,34.34,56,203,56 
,59,61 ,203,62,61 ,64,65, 73, 94 ,95 ,97, 98 ,99,99,99,99 ,99 ,101 
,105,106,107,106,109,110,110,111,112,114,110,110,110,110 
,110,116,117,119,120,121,43,122,37,129,126,126,126,127 
, 129,147,151 ,55,152,203, 203 ,153,154 ,155 ,175,177 ,203 ,160 
,202,203.203,205,206,208,129,209,203,203,2,215,217,1.4,6 
,8,10,13,15,18,20,22,25,28,31,34,37,42,44,46,48,50,53,56 
,58 ,60 ,62 ,64,66,76 ,80,82 ,84,86  ,88,90 ,92 ,94 ,97 ,100,102, 184 
,,106,103,115,343,199,305,315,311,237,299,299,299,299,299 
,299,299,299,299,291,199,1,2,2,4,4,6,6,7,7,7,9,9,10,10,10 
,12,12,12,12,12,12,12,12,12,12,12,12,12,12,19,19,20,20,21 
,21.22,22,24,24,24,24,25,27,28,29,30,31.31,31,31 ,31,35,35 
,37 ,36 ,38 ,38 ,38,36 , 38 , 38 ,36 , 36 ,36,42 , 42 , 43 , 43 , 44 , 44 , 44 ,44 
,44,46,46,46,51,51,54,54,56,56,56,60,60,62,62,65,65,65,67 
,67,67 ,68,68,69,69,69,69,69,69,70,70,79,79,80.80,81,81,82 
, 82 , 82 ,82 ,83 , 83 , 84 , 86 , 67 ,87 ,88 ,88 , 69 , 89 , 90 , 90 , 90 , 92 , 92 
, 107, 108, 145, 145, 145, 164, 180, 180, 181, 182, ie2, 182, 184, 184 
,184,185.185,190,190,191,192); 

DCL  INDEX2  (*)  BITE 

DATA(0, 1,1 ,21, 6, 1,5, 3, 3, 3, 3, 3 ,3, 1,5 ,3, 1,1, 2, 1,1, 6, 1,1, 2, 6 
,1,1,1  ,2, 1,5, 1,3, 1,1, 6, 1,1, 1,1,6, 1,1, 1,1, 2, 1,1, 1,1, 1,1  ,5 
,1,1,1,1,1,2,2,2,1,1,2,1,1,2,1,1,8,21,1,2,1,1.2,2,2,2,2,4 
,1,1,2,1.1,1,1,1,2,2,1,1,1,1,1,1,2,1,1,1,3,4,5,18,1,1,1,2 


18,4,1,1,1 ,1,1,1,1,20,2,3,1 ,22,1 ,1 ,2,1,2,1,18,6,1,1 ,21,2 
6,3,2,2,2,3,2,3,2,2,3,3,3,3,3,5,2,2,2,2,3,3,2,2,2,2,2,10 
4,2,2,2,2,2,2,2,3,3,2,2,2,2,7,3,27,58,66,67,69,81,87,86 
90,91.92,93,94,95,96,101,113,5,1 ,0,0,1 ,0,1, 1,2, 2,1 ,2,0,0 
2, 1,0, 2, 1,0, 1,4, 1,1, 3, 3, 1,3, 1,0, 1,0, 1,1, 2, 0,1, 1,0, 2, 0,1 
1,1,1 ,1,2, 2, 2, 5, 3, 0,1, 0,4, 4, 4 ,6, 6, 4, 6, 4, 4, 3, 0,1 ,0,1 ,0,2 
2, 1,1, 0,2, 2, 0,2, 0,2, 1,1, 2, 0,2, 0,2, 0,2, 2, 0,0, 1,0, 0,0, 0,0 
0,0, 0,0, 0,0, 0,0, 0,0, 0,0, 0,1, 0,1, 1,0, 0,1, 2, 0,0, 0,0, 0,0,0 
0,0, 0,0, 0,0, 0,0, 3, 0,2, 0,0, 0,0, 0,0, 0,0, 0,0, 0,1,0); 


/*  END  0?  TABLES  V 
DECLARE 

/*  JOINT  DECLARATIONS  V 

/*  THE  FOLLOWING  ITEMS  ARE  DECLARED  TOGETHER  IN  THIS 
GROOP  IN  ORDER  TO  FACILITATE  TPEIR  BEING  PASSED  FROM 
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THE  FIRST  PART  OF  THE  COMPILER. 

*/ 

DEBUGGING  3TTE, 

ERROR$CTR(5 )  BTTE, 

LINE$CTR(5)  BTTE, 

LISTABUFF(128)  BTTE, 

LISTSFCB (33 )  BTTE, 

LIST$INPUT  BTTE, 

LISTiPTR  ADDRESS, 

MAX$INT$MEM  ADDRESS, 

NEXT$ATAILABLE  ADDRESS, 

NEXTSSTM  ADDRESS, 

NO$CODE  BTTE, 

OUTPUT$B0FF ( 128 )  BTTE, 

OUTPUT $FCB( 33)  BTTE, 

OUTPUTSPTR  ADDRESS , 

POINTER  ADDRESS, 

PRI NT$PROD  BTTE, 

PRINT$TOKEN  BTTE, 

SEQ$NUM  BTTE, 

VRITE$LST  BTTE 

HASH$TAB$ADDR  ADDRESS,  /*  ADDRESS  OF  THE  BOTTOM  OF 

THE  TABLES  FROM  PARTI  */ 

/*  I  0  BUFFERS  AND  GLOBALS  */ 

IN$ADDR  ADDRESS  INITIAL  (5CH) , 

INPUTFCB  BASED  INADDR  (33)  BTTE, 

LISTSCHAR  BASED  LIST$?TR  BTTE, 

LIST$END  ADDRESS, 

OUTPUT$CHAR  BASED  OUTPUT$PTR  BTTE, 

OUTPUT$END  ADDRESS? 

/*  GLOBAL  PROCEDURES  */ 

DECLARE 

CTR  BTTE, 

a$ctr  address; 

MON1:  PROC  (F,A )  EXTERNAL; 

DCL  F  BTTE,  A  ADDRESS; 

END  MONi; 

M0N2:  PROC  (F,A )  BTTE  EXTERNAL; 

DCL  F  BTTE,  A  ADDRESS? 

END  M0N2; 

BOOT:  PROC  EXTERNAL? 

END  BOOT? 

PRINT$CHAR:  PROC  (CHAR); 
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DCL  CHAR  BYTE? 

CALL  M0N1  (2, CHAR); 

END  printcear; 

WRITESOUTPUT:  PROC  (BUFF.FCB); 

DCL  (BUFF ,FCB )  ADDRESS} 

CALL  MON1 (26, BUFF) }  /*  SET  DMA  */ 

IF  M0N2(21 ,FCB )  <>  0  TEEM 

do; 

CALL  M0N1(9,.('WR$')); 

CALL  boot; 

end; 

CALL  MON  1 (26 ,80H ) «  /PRESET  DMA  */ 

END  write$ootput; 

WRITE$TO$DISK !  PROC (CHAR); 

DCL  CHAR  BYTE} 

IF  (LIST$PTR  :=  LIST$PTR  ♦  l)  >  LIST$END  TEEN 

do; 

CALL  WRITE$OUTPUT(  .LIST$BUFF,  .LIST$FCB)  5 
LIST$PTR  =  .LIST$BOFF; 

end; 

LISTSCHAR  ■  CHAR? 

end  write$to$disk; 

PRINT:  PROC  (A); 

DCL  (A, ADDR)  ADDRESS, CHAR  BASED  ADDR  BYTE; 

ADDR  *  A} 

CALL  MON1  (9, A  )■} 

DO  WHILE  CHAR  <>  '$'} 

CALL  WR ITE$TO$DISK ( CHAR ) » 

ADDR  -  ADDR  +  1} 

end; 

END  print; 

CRLF:  PROC} 

CALL  MON1 (9 ,.(CR,LF,'$,)»); 

END  crlf; 

DCRLF:  PROC? 

CALL  WRITE$TO$DISK (CR ) ; 

CALL  WRITE$TO$DISK(LF); 

END  dcrlf; 

INC$CTR:  PROC (BASE); 

DCL  BASE  ADDRESS,  CTR  BYTE,  B$BYTE  BASED  BASE  (1)  BYTE, 
TEN  LIT  '3AH'} 

CTR  »  4} 

DO  WHILE  (B$BYTE( CTR)  :=  B$BYTE( CTR)  +  1)  =  TEN; 

Bi BYTE (CTR )  «  '0'; 

IF  CTR  >  0  TEEN 


IF  B$BYTE( CTR  :  =  CTR  -  1) 
B$BYTE(CTR)  *  'd'i 

END ; 

END  INC$CTR» 

PRINT$ERROR:  PROC  (CODE); 

DCL  CODE  ADDRESS, C0DE1(6)  ADDRESS 
I?  CODE  =  FALSE  THEN 
DO? 

DO  I  =  0  TO  5} 

CODEl(I)  *  0; 

end; 

i  =  0; 

end; 

ELSE  IF  CODE  *  TRUE  THEN 


THEN 


ADDRESS, I  BYTE? 


1  =  0; 

DO  VHILE( ( I  <>  6)  AND  (CODEl(I)  <>  0))j 
CALL  PRINTCHAR(HIC-H(CODEl(I))); 

CALL  PRINTCHAR( LOV  ( CODE1 ( I ) ) ) 5 
CALL  WRlTE$TO$DISK (HIGH (CODEl ( I ) ) ) J 
CALL  VRITE$TO$DISK(LOW  ( CCTE1 ( I ) ) ) 5 
CALL  crlf; 

CALL  dcrlf; 

CODEl ( I )  =  0; 

I  -  I  ♦  i; 

end; 

i  =  0; 

error  =  false; 


end; 

ELSE  IF  (CODE  =  'NP')  OR  (CODE 
OR  (CODE  =  'SL')  THEN 


'NV') 


ERROR  ■  TRUE; 

CALL  PRINTCHAR( HIGH (CODE ) ); 

CALL  PRINTCHAR(LOW  (CODE)); 

CALL  VRITE$TO$DISS( HIGH (CODE) ) ; 
CALL  WRITE$TO$DISK(LOV  (CODE)); 
CALL  INC$CTR( .ERRORACTR ( 0 ) ) ; 

IF  CODE  <>  'NP'  THEN 

do; 

CALL  crlf; 
call  dcrlf; 

end; 


end; 
else  do; 


error  »  true; 

IF  I  <>  6  THEN 

do; 

CODEl(I)  * 
I  «  I  +  i; 


code; 
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end; 

CALL  INC$CTR(.ERROR$CTR(0)); 

end; 

end  print$error; 

FATAL $ERROR :  PROC (REASON ) 5 
DCL  REASON  ADDRESS; 

CALL  PRINT$ ERROR (REASON ) ; 

CALL  PRINTSERROR(TRUE); 

CALL  boot; 
end  fatal$error; 

CLOSE:  PROC(FCB); 

dcl  pcb  address; 

IF  M0N2(16,FCB)  *  255  THEN  CALL  FATAL$ERROR( 'CL' ) 5 

END  close; 


MORES I N PUT :  PROC  BYTE; 

DCL  DC NT  BYTE; 

IF  (DC NT  :*  M0N2 (20 , . INPUT$FCB ) )  >  1  THEN 
CALL  FATAL$ERROR< 'BR'); 

RETURN  NOT(DCNT); 

END  mores in put; 


MOVE:  PROC (SOURCE,  DESTINATION,  COUNT); 

DCL  (COUNT, SOURCE, DESTINATION)  ADDRESS, 

(S$BYTE  BASED  SOURCE,  D$BYTE  BASED  DESTINATION)  BYTE; 
DO  WHILE  (COUNT  s*  COUNT  -  1)  <>  0FFFFH; 

D$BYTE  =  S$BYTE; 

SOURCE  =  SOURCE  *U 
DESTINATION  *  DESTINATION  +  15 

end; 
end  move; 


FILL:  PROC (ADDR, CHAR, COUNT); 

DCL  (ADDR, COUNT)  ADDRESS, 

(CEAR,DEST  BASED  ADDR)  BYTE; 

DO  WHILE  (COUNT  :*  COUNT  -  1)  <>  0FFFFH5 
dest«char; 

ADDR=ADDR  +  l; 

end; 
end  fill; 

/*  *****  SCANNER  LITS  ***#*/ 


DECLARE 


INPUT$STR 

LIT 

INVALID 

LIT 

LITERAL 

LIT 

LPARIN 

LIT 

PERIOD 

LIT 

'63 

'0' 

'42' 

'3' 

'1' 


* 
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f 


RPARIN  LIT  '6'; 

/*  *  *  *  *  SCANNER  TABLES  *  *  *  *  */ 


DCL  TOKEN $TABLE  (*)  BITE  DATA 

/*  CONTAINS  THE  TOKEN  NUMBER  ONE  LESS  THAN  THE  FIRST 
RESERVED  WORD  FOR  EACH  LENGTH  OF  WORD  V 
(0,0.12,18,25,42,54,63,73,77,80), 


TABLE  (*)  BYTE  DATA( 'BY' , 'GO' ,  IF', NO,  OR  ,  TO  j  EOF',  ADD 
, 'AND', 'END', 'I-O', 'NOT', 'RUN', 'CALL'.  ELSE',  EXIT' 

.  'FROM  '  ,  'INTO  ' ,  'LESS  '  ,  'MOVE  '  ,  'NEXT  '  ,  'OPEN  ' ,  'PAGE  .  'READ 
,  'SIZE ' , 'STOP  ' , 'THRU' . 'WITH' , 'ZERO' , 'AFTER ' , 'CLOSE' 

, 'ENTER', 'EQUAL', 'ERROR', 'I NPUT'.'OUOTF'. 'TIMES',  SPACE' 
'UNTIL', 'USING', 'WRITE', 'ACCEPT',  BEFORE',  DELETE 
,  'DIVIDE  '  , 'END-IF', 'GIVING' , 'OUTPUT ' , 'COMPUTE', 'DISPLAY' 
.'GREATER',  ' INVALID' , 'NUMERIC ', 'PERFORM ', 'REWRITE 
'ROUNDED', 'SECTION', 'VARYI NG ', 'DIV IS  ION ', 'MULTIPLY ' 
.'SENTENCE',  'SUBTRACT',  'ADVANCING',  'DEPENDING' 

, 'PROCEDURE', 'ALPHABETIC'), 

OFFSET  (11)  ADDRESS  INITIAL 

/*  NUMBER  OF  BYTES  TO  INDEX  INTO  THE  TABLE  FOR  EACH 
LENGTH  */ 

(0,0, 0,1? ,33,97,157,199,269,301 ,328 ) , 


WORD$COUNT  (*)  BYTE  DATA 

/*  NUMBER  OF  WORDS  OF  EACH  SIZE  V 
(0,0,6.7,16,12,7,10,4,3,1), 


AC CUM (82) 
APD$END(*) 
BUFFER $END 
CHAR 

DISPLAY(88) 

EOFFILLER 

FIRSTHINE 

FORMFEED 

HOLD 

INBUFF 

LOOKED 

MAI$ID$LEN 

MAX$LEN 

NEXT 

TAB 

TOKEN 


BYTE, 

BYTE  DATA(  '  EOF  '). 

ADDRESS  INI TI AL( 100H  ) , 

BYTE  INITIALS  '), 

BYTE  INITIALS), 

LIT  '1AH', 

BYTE  INITIAL(TRUE), 

LIT  '0CH' , 

BYTE, 

LIT  '80H' , 

BYTE  INITIALS), 

LIT  '15', 

LIT  '10', 

BASED  POINTER  BYTE, 

LIT  '09' 

BYTE?  /•RETURNED  FROM  SCANNER  */ 


/*  PROCS  USED  BY  THE  SCANNER  */ 


NEXT$CHAR:  PROC  BYTE; 
IF  LOOKED  THEN 

do; 
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LOOKED  =  FALSE; 

RETURN  (CHAR  :=  HOLD); 

end; 

IF  (POINTER  :  =  POINTER  +  1 )  >=  BUFFER$END  THEN 

do; 

IF  NOT  MORE$I NPUT  THEN 

do; 

BUFFER$FND  =  .MEMORY; 

POINTER  *  .ADD$END; 

end; 

ELSE  POINTER  *  INBUFF; 

end; 

IF  NEXT  «  EOFFILLER  THEN 

do; 

BUFFER $END  *  .MEMORY? 

POINTER  *  .ADD$END? 

end; 

RETURN  (CHAR  :=  NEXT); 

END  next$char; 

GET$CHAR:  PROC; 

CHAR  =  next$char; 
end  get$char; 

DISPLAY$LINE:  PROC? 

DCL  I  byte; 

DO  I  *  1  TO  DISPLAY (0 ) » 

IF  LIST$ INPUT  OR  ERROR  THEN 

CALL  PRINT$CHAR(DISPLAY(I)); 

IF  WRITE$LST  OR  ERROR  THEN 

CALL  vrite$to$disk(display(i)); 

end; 

IF  FIRST$LINE  THEN 

do; 

CALL  MOVE( .LINE$CTR , .DISPLAY ( 1 )  ,5 ) ? 
FIRST$LINE  =  FALSE? 

end; 

ELSE  CALL  INC$CTR ( .DISPLAY (0) )  ? 

DISPLAY (0 )  «  5? 

END  display$line; 

L0AD$DISPLAY :  PROC? 

IF  DISPLAY(0)  <  87  THEN 

DISPLAY ( DISPLAY (0 )  :*  DISPLAY(0)  ♦  l)  *  CHAR 
CALL  get$char; 

END  LOADSDISPLAY? 

PUT:  PROC? 

IF  ACCUM(0)  <  81  THEN 

ACCUM(ACCUM(0)  :*  ACCUM(0)  +  1 )  ■  CHAR? 

CALL  LOAD$DISPLAY? 


END  POT? 

EAT$LINE:  PROC; 

DO  VEILS  CHAR  <>  CR; 

CALL  load$displat; 
end; 

end  eat$line; 

GET$NO$BLANI:  PROC.' 

DCL  I  bite; 
do  forever; 

IF  CHAR  »  '  '  OR  CHAR  =  TAB  THEN  CALL  LOAD$DI SPLAT 
ELSE  IF  CHAR=CR  THEN 

do; 

CALL  LOAD$DI SPLAT; 

CALL  load$displat; 

CALL  DISPLAT$LINSJ  ' 

CALL  PRINT$ERROR(TRDE); 

DO  WHILE  CHAR  *  CRT 
CALL  load$displat; 
call  load$displat; 
call  displathine; 

end; 

IF  SEQ$NUM  THEN 
DO  I  *  1  TO  e; 

CALL  loadsdisplat; 
end; 

IF  CHAR  *  THEN  CALL  EAT$LINEJ 
ELSE  IF  CHAR  *  V'  THEN 

do; 

IF  LIST$INPUT  THEN 

CALL  PRINT$CHAR(FORM$FEED)? 

IF  WRITE$LST  THEN 

CALL  WRITE$TO$DISK  (FORMFEED); 
CALL  eat$line; 

end; 

ELSE  IF  CHAR  »  TEEN 

IF  NOT  DEBUGGING  THEN  CALL  EAT$LINE; 
ELSE  CALL  LOAD$DISPLAT i 

end; 

else  return; 

end;  /*  END  OF  DO  FOREVER  */ 

END  GET$NO$BLANi; 

SPACE:  PROC  BTTE; 

RETURN  (CHAR  ■  '  ' )  OR  (CHAR  *  CR )  OR  (CHAR  =  TAB); 

end  space; 

LEFT$PARIN:  PROC  BTTE; 

RETURN  CHAR  •  '('; 

END  lzft$parin; 
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right$parin:  proc  bite; 

RETURN  CHAR  *  ')'; 

END  right$parin; 

DELIMITER:  PROC  BITE? 

IE  CHAR  <>  THEN  RETURN  FALSE; 

HOLD  =  NEXT$CHARJ 

loosed  =  true; 

IE  SPACE  THEN 

do; 

char  » 

RETURN  TRUE? 

end; 
char  * 

RETURN  FALSE; 

end  delimiter; 

END$OFSTOKEN:  PROC  BYTE; 

RETURN  SPACE  OR  DELIMITER  OR  LEFT$PARIN  OR  RIGET$PA5IN; 
END  end$of$token; 

GET$LITERAL:  PROC  BYTEi 
CALL  load$display; 
do  forever; 

IF  CHAR  «  QUOTE  THEN 

do; 

CALL  LOAD$DI SPLAY; 

RETURN  LITERAL; 

end; 
call  put; 
end; 

end  getuiteral; 

LOOSSUP:  PROC  BYTE; 

DCL  POINT  ADDRESS, 

HERE  BASED  POINT  (1)  BYTE,  I  BYTE; 

MATCH:  PROC  BYTE; 

DCL  J  byte; 

DO  J  *  1  TO  ACCUM(0)J 

IF  RERE(J  -  1)  <>  ACCUM(J)  THEN  RETURN  FALSE; 

end; 

RETURN  TRUE; 

end  match; 

POINT  «  OFFSET (AC CUM ( 0 ) )  +  .TABLE; 

DO  I  -  1  TO  VORD$COUNT(ACCUM(0)); 

IF  MATCH  THEN  RETURN  I; 

POINT  *  POINT  ♦  ACCUM(0); 

end; 
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RETURN  FALSE; 

END  LOOK$UP? 

RESERVED$WORD :  PROC  BTTEJ 
ECL  (NUMB  .VALUE)  BYTE? 

I?  ACCUM(0)  <=  MAX$LEN  THEN 

do; 

IF  (NUMB  :=  TOKEN$TABLE(ACCUM(0 ) ) )  O  0  THEN 
IF  (VALUE  :=  LOOK$UP )  <>  0  THEN 
NUMB  «  NUMB  *  VALUE; 

ELSE  NUMB  =  0; 

end; 

ELSE  NUMB  =  0? 

RETURN  NUMB; 

end  reserved$vord; 

GET$TOKEN:  PROC  BITE; 

ACCUM(0)  »  0; 

CALL  get$no$blank; 

IF  CHAR  *  QUOTE  THEN  RETURN  GET$LITERAL; 

IF  DELIMITER  THEN 

do; 

CALL  put; 

RETURN  PERIOD; 

end; 

IF  LEFT$PARIN  THEN 

do; 

call  put; 

RETURN  LPARINJ 

end; 

I?  RIGHT$PAR IN  TEEN 

do; 

call  put; 

RETURN  RPARIN; 

end; 

do  forever; 
call  put; 

IF  END$OF$TOKEN  THEN  RETURN  INPUT$STRJ 
END;  /*  OF  DO  FOREVER  */ 

END  get$token; 

/*  END  OF  SCANNER  ROUTINES  */ 

/*  SCANNER  EXEC  */ 

SCANNER:  PROC ; 

IF(TOKEN  :»  GET$TOKEN)  *  INPUT$STR  THEN 

IF  (CTR  :»  RESERVED$¥ORD)  <>  0  THEN  TOKEN  =  CTR; 
END  scanner; 

PPINT$ACCUM:  PROC? 

DCL  I  byte; 

DO  I  -  1  TO  ACCUM(0); 

CALL  PRINT$CHAR(ACCUM(I)); 
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CALL  VRITE$T0$DISK(ACCUM( I ) )  J 

end; 

call  crlf; 
call  dcrlf; 
end  print$accum; 

PRINT$NUMBER:  PROC(NUMB); 

DECLARE (NUMB , I ,CNT,K)  BITE,  J  (*)  BITE  DATA ( 100 , 10 ) ; 
DO  I  -  0  TO  1J 
CNT  •  di 

DO  WHILE  NUMB  >=  (S  :  =  J ( I ) ) ; 

NUMB  *  NUMB  -  KJ 
CNT  »  CNT  +  1J 

end; 

CALL  PRINTCFAR('0'  +  CNT); 

end; 

CALL  PRINTCHAR ( '0  '  ♦  NUME); 

END  print$number; 

/*  *  *  *  end  of  scanner  procs  *  *  *  */ 


/**♦**  symbol  table  declarations  *  *  *  */ 

DECLARE 


CUR$SYM 

ADDRESS,  /’•‘SYMBOL  BEING  ACCESSED 

DECIMAL 

LIT 

'11'. 

DISPLACEMENT 

LIT 

'14'. 

FCB$ADDR 

LIT 

'4'. 

FLD$LENGTE 

LIT 

'3'. 

HASH$MASS 

LIT 

3FH'  , 

LEVEL 

LIT 

'10'. 

LOCATION 

LIT 

'2'. 

P$LENGTH 

LIT 

'3'. 

RELSID 

LIT 

'5'. 

S$TTPE 

LIT 

'2'. 

STARTS NAME 

LIT 

'13',  /*1  LESS*/ 

SYMBOL 

BASED 

CUR$SYM  (1)  BYTE, 

SYMBOL$ADDR 

BASED 

CURSSYM  (1)  ADDRESS. 

TEMP$PTR 

ADDRESS, 

TEMP$ADDR 

BASED 

TEMP$PTR  ADDRESS, 

/*  *  *  *  * 

*  *  SYMBOL  TYPE  LITERALS  ******  */ 

A$ED 

LIT 

'72', 

A$N$ED 

LIT 

'73', 

ALPHA 

LIT 

'8', 

ALPHA$NUM 

LIT 

'9', 

COMP 

LIT 

'21', 

GROUP 

LIT 

'6', 

LABELiTTPE 

LIT 

'32', 

LIT$QUOTE 

LIT 

'11', 

LIT$SPACE 

LIT 

'10', 

LITiZERO 

LIT 

'12'. 
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MULT$OCCURS 

LIT 

non$numeric$lit 

LIT 

NUM$ED 

LIT 

NUMERIC 

LIT 

NUMERIC$LITERAL 

LIT 

UNRESOLVED 

LIT 

'128' 

'7' 

'ea' 

'16' 

'15' 

'255' 


t 


* 

9 


/*  *  *  *  SYMBOL  TABLE  ROUTINES  *  *  *  */ 


SET$ADDRESS:  PROC(ADDR)! 

DCL  A  DDR  ADDRESS! 

STMBOL$ADDR( LOCATION)  =  ADDRJ 
END  SET$ADDRESS! 

GET$ADDRESS:  PROC  ADDRESS! 

RETURN  SYMBOL$ADDR(LOCATION)J 
END  GET$ ADDRESS  ! 

GET$FCB$ADDR:  PROC  ADDRESS! 

RETURN  SYMBOL$A£CR(ECB$ADDR) ! 

END  GET$?CB$ADDR! 

GET$TYPE:  PROC  BITE! 

RETURN  STMBOL(S$TYPE); 

END  GET$TYPE! 

SET$TYPF :  PROC (TYPE)! 

DCL  TYPE  BYTE! 

SYMBOL(S$TYPE)  =  TYPE! 

END  SET$TY PE! 

GET$LENGTH :  PROC  ADDRESS! 

RETURN  SYM30L$ADDR(FLD$LENGTH) ! 

END  get$length; 

GET$LEVEL:  PROC  BYTE! 

RETURN  SYMBOL(LEVEL)! 

END  GET$LEVEL! 

GET$DECIMAL:  PROC  BYTE! 

RETURN  SYMBOL (DECIMAL ) ! 

END  GET$DECIMAL! 

GET$P$LENGTH :  PROC  BYTE! 

RETURN  SYMBOL ( P $LENGTH ) ! 

END  GET$P$ LENGTH! 

BUILD$SYMBOL:  PROC(LEN)! 

DCL  LEN  BYTE,  TEMP  ADDRESS! 

TEMP  -  NEXT$SYMJ 

IF  (NEXT$SYM  :«  .SYMBOL( LEN  :■  LEN  ♦  DISPLACEMENT)) 
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>  MAX$MEMOPY  THEM  CALL  FATAL$ERROP  ( 'ST') » 

CALL  JILL  (TEMP.0.LEN)? 

END  BOILr$STKBOLJ 

GET$PREV$OCCURS :  PROC  ADDRESS* 

TEMPiPTR  «  CUR$SYM  +  DISPLACEMENT  +  GET$P$LENGTH  * 
RETURN  temp$addr; 

END  GET$PREV$OCCURS? 

AND$OUT$OCCURS :  PROC  (TYPE$IN)  BYTE? 

DCL  TTPE$ IN  BITE? 

RETURN  TTPE$IN  AND  127? 

END  A  ND$OUT$OCCURS ? 

CHECK$UNRESOLVED:  PROC* 

DCL  (I,J)  BTTE.PTR  ADDRESS ,ADDR$PTR  BASED  PTR  ADDRESS? 
PTR  «  HASH$TAB$ADDR?/*SET  PTR  TO  FIRST  BASH  A  DDR*/ 

DO  I  =  1  TO  64? 

IP  ADDR$PTR<>0  THEN 
DO? 

CUR$STM  *  ADDR$PTR? 

DO  WHILE  CURSYMO0? 

IF  GET$TTPE  *  UNRESOLVED  THEN 
DO? 

CALL  PRINT(.('UL  $'))? 

DO  J  -  1  TO  GET*P$LENGTE? 

CALL  PRINT$CHAR(SYMBOL(START*NAME  *  J))? 
CALL  WRITE$TO$DISK(STMBOL(START$NAME  +  J 
END? 

CALL  CRLF? 

CALL  DCRLF? 

CALL  INC$CTR( . ERRORS CTR (0 )  )  ? 

END? 

CURSYM  =  STMBOL$ADDR( 0  )  ? 

END? 

END? 

PTP.  «  PTR  +2? 

END? 

END  CHECKSUNRESOLVED? 

/*  *  *  *  PARSER  DECLARATIONS  *  *  *  V 


DCL 

COMPILING 

BYTE  INITIAL(TRUE) , 

CONUENGTH 

BYTE, 

COND$TYPE 

BYTE, 

DISPLAY  $FLAG 

BYTE  INITIAL(FALSE) 

HOLD$SEC$ADDR 

ADDRESS, 

HOLDiSECTION 

ADDRESS, 

ID$PTR 

BYTE, 

ID$STACE(20) 

ADDRESS, 

(I.J.S)  ADDRESS, 

L$ADDR  ADDRESS, 

L$DEC  BITE, 

L$DEC$TEMP  BITE, 

L$LENGTH  ADDRESS, 

l$TTPE  BITE, 

HP  BITE, 

MPP1  BITE, 

NEXT$ADDRESS  ADDRESS 

NOLOOK  BITE 

PSTACKSIZE  LIT 

SECTION$FLAG  BITE 

SP  BITE 

STATE  ADDRESS 

STATESTACK(PSTACKSIZE)  ADDRESS, 
SUB$IND  BITE 

VARC( 100)  BITE, 

VALUE( PS TACKS IZE )  ADDRESS, 

VALUE2( PSTACKSIZE)  ADDRESS, 

WRITE$BEFORE  BITE 

WRITE$AFTSR  BITE 


/*INDICIES  FOR  THE  PARSER*/ 


INITIAL(0), 

INITIAL(FALSF). 

'30 ' ,  /*  SIZE  OF  STACKS*/ 
INITIAL(0 ) , 

INITIAL(255) , 

INITIAL (STARTS ) , 

/*  SAVED  STATES  */ 
INITIALS), 

/*TEMP  CHAR  STORE*/ 

/*  TEMP  VALUES  */ 

/*  VALUE2  STACK  */ 
INITIAL (FALSE) , 
INITIAL(FALSE) , 


/*»*****«  CODE  LITERALS  *****♦•#**/ 

/*  THE  CODE  LITERALS  ARE  BROKEN  INTO  CROUPS  DEPENDING 
ON  THE  TOTAL  LENGTH  OF  CODS  PRODUCED  FOR  TEAT  ACTION  */ 
/*  LENGTH  ONE  */ 


ADD  LIT  '1',  /*  ADD  REGISTER  1  TO  REGISTER  0  */ 

SUB  LIT  '2',  /*  SUBTRACT  REGISTER  1  FROM  REGISTER  0  */ 

MUL  LIT  '3',  /*  MULTIPLI  REGISTER  0  BI  REGISTER  1  */ 

DIV  LIT  '4',  /*  DIVIDE  REGISTER  0  BT  REGISTER  1  */ 

NEG  LIT  '5',  /*  NOT  OPERATOR  */ 

STP  LIT  '6',  /*  STOP  PROGRAM  */ 


STI 

LIT 

/*  STORE  REGISTER  2  INTO  REGISTER  0  */ 

EXT 

LIT 

/* 

'a', 

LENGTH 

/*  EXIT  SUBROUTINE  */ 

TWO  */ 

RND 

LIT 

/* 

'9', 

LENGTH 

/*  ROUND  CONTENTS  OF  REGISTER  ?  */ 

THREE  */ 

RET 

LIT 

/*  RETURN  */ 

CLS 

LIT 

11', 

/*  CLOSE  */ 

SER 

LIT 

12'. 

/*  BRANCH  ON  SIZE  ERROR  */ 

BRN 

LIT 

'13', 

/*  BRANCH  */ 

OPN 

LIT 

'14', 

/*  OPEN  A  FILE  FOR  INPUT  */ 

OP1 

LIT 

'15'. 

/*  OPEN  A  FILE  FOR  OUTPUT  */ 

0P2 

LIT 

/*  OPEN  A  FILS  FOR  BOTH  INPUT  ANT  OUTPUT  */ 

RGT 

LIT 

'1?'. 

/*  REGISTER  GREATER  THAN  */ 

RLT 

LIT 

'16' 

/*  REGISTER  LESS  THAN  */ 

REQ 

LIT 

,l9,» 

/*  REGISTER  EQUAL  */ 

INV 

LIT 

'20', 

/*  BRANCH  I?  INVALID-FILE-ACTION  FLAG  TRUE  */ 

EOR 

LIT 

/* 

'21', 

LENGTH 

/*  BRANCH  ON  END-OF-RECORDS  FLAG  */ 

FOUR  */ 

PAG 

LIT 

'22' 

/* 

CARRIAGE  CONTROL  FOR  PRINTER  OPERATION  */ 

ACC 

LIT 

'23', 

/* 

ACCEPT  */ 

STD 

LIT 

'24', 

/* 

STOP  WITH  DISPLAY  */ 

LDI 

LIT 

'25'. 

/* 

LOAD  A  CODE  ADDRESS  DIRECT  */ 

/*  LENGTH  FIVE  V 

CIS  LIT  '26',  /*  DISPLAY  */ 

DEC  LIT  '27',  /*  DECREMENT  COUNT  AND  BRANCH  IF  ZERO  */ 

STO  LIT  '28',  /*  STORE  NUMERIC  V 

ST1  LIT  '29',  /*  STORE  SIGNED  NUMERIC  LEADING  */ 

ST2  LIT  '30',  /*  STORE  SIGNED  NUMERIC  TRAILING  V 

ST3  LIT  '31',  /*  STORE  SEPARATE  SIGN  LEADING  V 

ST4  LIT  '32',  /*  STORE  SEPARATE  SIGN  TRAILING  */ 

ST5  LIT  '33',  /*  STORE  A  PACKED  NUMERIC  FIELD  */ 

/*  LENGTH  SIX  */ 

LOD  LIT  '34',  /*  LOAD  NUMERIC  LITERAL  */ 

LD1  LIT  '35',  /*  LOAD  NUMERIC  */ 

LD2  LIT  '36',  /*  LOAD  SIGNED  NUMERIC  LEADING  */ 

LD3  LIT  '37',  /*  LOAD  SIGNED  NUMERIC  TRAILING  */ 

LD4  LIT  '38',  /*  LOAD  SEPARATE  SIGN  LEADING  */ 

LD5  LIT  '39',  /*  LOAD  SEPARATE  SIGN  TRAILING  */ 

LD6  LIT  '40',  /*  LOAD  A  PACKED  NUMERIC  FIELD  */ 

/*  LENGTH  SEVEN  V 


PER 

LIT 

'41'. 

/* 

PERFORM  */ 

CNU 

LIT 

'42'. 

/* 

COMPARE  NUMERIC  UNSIGNED  */ 

CNS 

LIT 

'43'. 

/* 

COMPARE  NUMERIC  SIGNED  */ 

CAL 

LIT 

'44', 

/* 

COMPARE  ALPHABETIC  */ 

RVS 

LIT 

'45'. 

/* 

REWRITE  SEQUENTIAL  */ 

DLS 

LIT 

'46', 

/* 

DELETE  SEQUENTIAL  V 

RDF 

LIT 

'47'. 

/* 

READ  A  SEQUENTIAL  FILE  */ 

WTF 

LIT 

'48,'. 

/* 

WRITE  A  RECORD  TO  A  SEQUENTIAL  FILE  */ 

RVL 

LIT 

49', 

/* 

READ  A  VARIABLE  LENGTH  FILE  */ 

WVL 

LIT 

'50', 

/* 

WRITE  A  VARIABLE  LENGTH  RECORD  V 

/* 

LENGTH 

NINE  */ 

SCR 

LIT 

'si ;. 

/*  CALCULATE  A  SUBSCRIPT  <7 

SGT 

LIT 

'52'. 

/*  STRING  GREATER  THAN  */ 

SLT 

LIT 

'53', 

/*  STRING  LESS  THAN  */ 

SEQ 

LIT 

'54;, 

/*  STRING  EQUAL  */ 

MOV 

LIT 

'55', 

/*  MOVE  V 

/* 

LENGTH 

TEN  */ 

RRS 

LIT 

'56;, 

/*  READ  RELATIVE  SEQUENTIAL  */ 

WRS 

LIT 

'57', 

/*  WRITE  RELATIVE  SEQUENTIAL  */ 

RRR 

LIT 

'se'. 

/*  READ  RELATIVE  RANDOM  */ 

WRR 

LIT 

'59', 

/*  WRITE  RELATIVE  RANDOM  */ 

RWR 

LIT 

'60', 

/*  REWRITE  RELATIVE  */ 

DLR 

LIT 

'61'. 

/*  DELETE  RELATIVE  */ 

/* 

LENGTH 

ELEVEN  */ 

MED 

LIT 

'62', 

/*  MOVE  INTO  AN  ALPHANUMERIC  EDITED  FIELD  */ 

/* 

LENGTH 

THIRTEEN  */ 

MNE 

LIT 

;e3;. 

/*  MOVE  INTO  A  NUMERIC  EDITED  FIELD  */ 

SBR 

LIT 

'64', 

/*  SUBROUTINE  CALL  */ 

/*  VARIABLE  LENGTH  */ 


GDP  LIT  '65',  /*  GO  TO  -  DEPENDING  ON  */ 

PAR  LIT  '66',  /*  PARAMETER  LIST  */ 

/*  BUILD  DIRECTING  ONLY  */ 

INT  LIT  '67',  /*  INITIALIZE  MEMORY  V 

BST  LIT  '68',  /*  BACK  STUFF  */ 

TER  LIT  '69',  /*  TERMINATE  BUILD  */ 

SCL  LIT  '70'J  /*  START  CODE  V 

/*  *  *  *  PARSER  ROUTINES  »****/ 

DIGIT:  PROC  (CHAR)  BYTE* 

DCL  CHAR  BYTE; 

RETURN  (CHAR  <=  '9')  AND  (CHAR  >=  '0'); 

END  digit; 

LETTER:  PROC  (CHAR)  BYTE; 

DCL  CHAR  BYTE*, 

RETURN  (CHAR  >*  'A')  AND  (CHAR  <=  'Z')J 
END  letter; 

INVALID$TYPE:  PROC? 

CALL  PRINT$ERR0R( 'IT'); 

END  IN7ALID$TYPE; 

BYTE$OUT:  PROC(ONE$BYTE)t 
DCL  ONE$BYTE  BYTE; 

IF  NO$CODE  THEN  RETURN; 

IF  (OUTPUT$PTR  :*  OUTPUT$PTR  ♦  1)  >  OUTPUTSEND  THEN 

do; 

CALL  VHITE$OUTPUT( .OUTPUT$BUFF, .OUTPUT$FCE) ; 
OUTPUT$PTR  *  .output$buff; 

end; 

output$char  a  ont$byte; 
end  byte$out; 

ADDR$OUT:  PROC  (ADDR); 

DCL  ADDR  ADDRESS; 

CALL  BYTS$OUT(LOV (ADDR) ) * 

CALL  BYTE$OUT(HIGH  (ADDR)); 

END  ADDR$OUT5 

INC$COUNT:  PROC(CNT); 

DCL  CNT  BYTE; 

I F( NEXT$ AVAILABLE  :»  NEIT$AVAILABLE  +  CNT) 

>  MAX$INT$MEM  THEN  CALL  FATAL$ERROR ( 'MO  ' ) * 

END  INC$COUNTJ 

ONE$ADDR$OPP:  PROC (CODE, ADDR ) ; 

DCL  CODE  BYTE,  ADDR  ADDRESS; 

CALL  BYTE$OUT(CODE); 

CALL  ADDR$OUT(ADDR); 

CALL  INC$C0UNT{3),’ 


END  0NE$ADDR$0PPJ 


MATCH:  PROC  ADDRESS,* 

DCL  POINT  ADDRESS,  COLLISION  BASED  POINT  ADDRESS, 

(HOLD, I)  BITE? 

IP  mC(0)>M.AX$ID$lEN  TE5H  VARC(O)  »  MAX$ID$LEN; 

HOLD  »  0? 

DO  I  *  1  TO  VARC(0); 

HOLD  =  HOLD  ♦  PARC (I )J 

end; 

POINT  »  HASH$TAB$ADDR  +  SHL((BOLD  AND  EAS3$MASK  ) ,  1 )  ,* 

DO  forever; 

IF  COLLISION  »  0  THEN 

do; 

CUR$STM, COLLISION  =  NEXT$SYMJ 
CALL  BUILD$SYMBOL( PARC (0 )  ) » 

SYMBOL(P$LENGTH )  =  PARC(0); 

DO  I  -  1  TO  VARC(0); 

SYMBOL ( S7ART$NA ME  ♦  I )  *  PARC (I); 

end; 

CALL  SET$TYPE(CNRESOLVED); 

RETURN  CUR$SYM| 

end; 

ELSE 

do; 

cur$sym=collision; 

IF  (HOLD:=GET$P$LENGTH)=VARC(0)  THEN 

do; 

ici ; 

DO  WHILE  SYMBOL(START$NAMS  +  I)=  PARC(I); 
IF  ( I :=I+1 ) >HOLD  THEN 

RETURN <C0R$ STM  :=  COLLISION); 

end; 

end; 

end; 

point  »  collision; 

end; 

end  match; 

SET$PALUE:  PROC (NUMB)? 

DCL  NUMB  ADDRESS? 

VALUE (MP)  *  NUMB; 

end  set$palue; 

SET$PALUE2:  proc(addr); 

DCL  ADDR  ADDRESS; 

VALUER (MP)  «  ADDR; 

END  SET$PALUE2; 

CHE$UD$PAR:PROC(PTR); 

DCL  PTR  BYTE? 
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CURS YM  »  VALUE (PTR); 

IF  GET$TYPE  *  UNRESOLVED  THEN 
CALL  PRINT$ERROR( 'UD') ♦ 

END  CEK$UDiVAR* 

SUB$CNT:  PROC  BYTE? 

IF  ( SU3$IND  !«  SUB$ IND  +  l)  >  7  TEEN 
SUB$ IND  »  IS 
RETURN  SUB$IND; 

END  SUB$CNTJ 

CODE$BYTE:  PROC  (CODE); 

DCL  CODE  BYTE? 

CALL  BYTE$OUT(CODE); 

CALL  INC$COUNT(l); 

END  C0DE$3YTE; 

CODE$ADDRESS :  PROC  (CODE); 

DCL  CODE  address; 

CALL  ADDR$OUT(COEE)J 
CALL  INC$COUNT(2); 

END  code$address; 

CONVERTS  INTEGER:  PROC  ADDRESS; 

DCL  A  byte; 
actr  =  0; 

IF  VARC(l)  =  THEN  A  *  2;  ELSE  A  =  1? 

DO  CTR  =  A  TO  VARC(0); 

IF  NOT  DIGIT(VARC (CTR) )  TEEN 

do; 

CALL  PRINT$ERROR('NN'); 

RETURN  A$CTR; 

end; 

ELSE  A$CTR  *  SHL( ACTR, 3)  +  SHL(ACTR.l)  + 

VARC (CTR)  -  '0'; 

end; 

RETURN  actr; 

end  convert$integer; 

BACKSTCFF:  PROC  (ADD1.ADD2); 

DCL  (ADD1.ADD2)  ADDRESS; 

CALL  BYTE$OUT(BST) ; 

CALL  ADDR$OUT(ADDl); 

CALL  ADDR$0UT(ADD2); 

END  BACKiSTUFF; 

CHK$NIT$SENTENCE:  PROC; 

IF  NEZT$ ADDRESS  <>  0  TEEN 

do; 

CALL  BACKSTUFF(NEXT$ ADDRESS fNEXT$ AVAILABLE^ 

neztuddress  -  0; 

t 
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end; 

end  chk$nxt$sentence; 

UNRES$BRANCH :  PROC; 

CALL  SET$VALUE(NEXT$AVAILABLE  +  l)J 

CALL  ONE$ADDR$OPP(BRN.0)J 

CALL  SET$VALUE2(NEXTAArVArLA'BLE); 

END  UNRES$BRANCHJ 

BACKiCOND:  PROC,* 

CALL  BACKSTUFF ( VALUE ( SP  -  1 ) ,NEXT$A VAILABLE) ; 
END  bacs$cond; 

SET$BRANCH :  PROC » 

CALL  set$value(next$available); 

CALL  CODE$ADDRESS(0); 

END  SET$BRANCRJ 

KEEP$VALUES :  PROCi 

CALL  SET$VALUE( VALUE ( SP ) ) » 

CALL  SET$VALUE2 (VALUE2(SP) ) » 

END  KEEP$VALUESJ 

C A HRAGE$ CONTROL:  PROCJ 

VRITE$BEFORE,VRlTE$AFTER  =  FALSE  * 

CALL  CODE$BYTE(PAG); 

CALL  code$address(get$fcb$addr); 

CALL  CODE$BYTE ( VALUE( SP ) ) J 
END  carrage$control; 

STD$ATTRIBUTES:  PROC(TYPE); 

DCL  TYPE  BYTE? 

CALL  CODE$ADDRESS(GET$FCB$ADDR); 

CUR$SYK  »  GET$ADDRESSJ 

CALL  CODE$ADDRESS(GET$ADDRESS ); 

CALL  CODE$ ADDRESS (GET$LENGTH ) ; 

IF  TYPE  »  0  THEN  RETURN; 

CURiSYM  =  get$fcb$addr; 

CUR$SYW  «  SYMBOL$ADDR(REL$ID) ; 

CALL  CODE$ADDRESS(GET$ADDRESS); 

CALL  CODE$BYTF(GET$LENGTH); 

END  STD$ATTRIBUTES; 

WRITE$A$RECORD:  PROC; 

DCL  TEMP$SYM  ADDRESS? 

IF  GET$LEVEL  <>  1  THEN  CALL  PRlNT$ERROR( 'WL') ; 
ELSE 

do; 

TEMP$SYM  «  CUR$SYM; 

CUR$SYM  a  get$fcb$addr; 

IF  (CTR  :=  GET$TYPE)  <>  1  AND 
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(WRITE$BEFORE  OR  WRITE$f FTER )  THEN 
CALL  PRINT$ERROR( 'CC'); 

IE  CTR  =  1  THEN 

ro; 

IE  VRITE$AFTER  THEN  CALL  CARRAGE$ CONTROL* 
CALL  COEE$BYTE(WTF) * 

CALL  STD$ATTRIBUTES (0 ) » 

I?  VfRITE$BEFORE  THEN 

do; 

cur$sy*  =  get$fcb$addr; 
call  carrage$control; 

end; 

end; 

ELSE  IE  CTR  *  2  THEN 

do; 

call  code$byte(vrs); 

CALL  STD$ATTRIBUT£S(1); 

end; 

ELSE  IE  CTR  =  3  THEN 

do; 

CALL  CODE$BYTE(WRR); 

CALL  STD$ATTRIBUTES(1); 

end; 

ELSE  IF  CTR  =  4  THEN 

do; 

CALL  CODE$BYTE(WTL); 

CALL  CODE$ADDRESS(GET$FCB$ADDR); 

CDRSSYM  «  temp$sym; 

CALL  CODE$ADDRESS(GET$ADDRESS); 

CALL  CODE$ADDRESS(GET$LENGTH) ? 

end; 

ELSE  CALL  PRI NT $ERR OR (  'FT  *  ) ; 

end; 

end  write$a$record; 

READ$A$FILE:  PROCJ 

IF  (CTR  :=  GET$TYPE)  *  1  THEN 

do; 

CALL  C0DE$3YTE(RDF) ; 

CALL  STD$ ATTRIBUTES ( 0 ) J 

end; 

ELSE  IF  CTR  »  2  THEN 

do; 

CALL  CODE$BYTE(RRS); 

CALL  STD$ATTRIBUTES(1); 

end; 

ELSE  IF  CTR  »  3  THEN 

do; 

CALL  CODESBYTE(RRR); 

CALL  stduttributes(i); 

end; 


ELSE  IF  CTR  *  4  THEN 

do; 

CALL  CODE$BTTE(RVL); 

CALL  CODE$ADDRESS(GET$FCB$ADDR ) » 

CALL  CODE$ADDRESS(GET$LENGTH); 

CUR$SYM  *  GET$ADDRESS; 

CALL  CODE$ADDRESS(GET$ADDRESS ); 

end; 

ELSE  CALL  PRINT$ERROR( 'FT') ; 

END  read$a$file; 

ARITHMETIC$TYPE:  PROC  BYTE? 

IF  ( (L$TYPE  !*  AN D $ OUT $ OCCURS ( L$TYPE ) )  >= 

NUMERIC ^LITERAL)  AND  (L$TYPE  <=  COMP)  THEN 
RETURN  L$TYPS  -  NUMERIC$LITERAL; 

IF  L$TYPE  =  LIT$ZERO  OR  L$TYPE  *  ALPHA$NUM  THEN 
RETURN  0} 

CALL  invalid$type; 

RETURN  0; 

END  arithmetic$type; 

DELETE$A$FILE :  PROC? 

IF  (CTR  :*  GET$TYPE)  ■  3  THEN 

do; 

CALL  CODE$BYTE(DLR); 

CALL  STD$ATTRIBUTES(1); 

end; 

ELSE  IF  CTR  =  2  THEN 

do; 

CALL  CODE$BYTE(DLS); 

CALL  STD$ATTRIBUTES(0); 

end; 

ELSE  CALL  PRINT$ERROR( 'IT'); 

END  delete$a$file; 

REWRITE$A$RECORD:  PROC; 

IF  GETHE7EL  <>  1  THEN  CALL  PRINT$ERROR  (  'WL ' )  J 
ELSE 

do; 

CUR$SYM  *  get$fcb$addr; 

IF  (CTR  :«  GET$TYPE)  =  3  THEN 

do; 

CALL  CODE$BYTE(RVR ); 

CALL  STD$ATTRIBUTES(1); 

end; 

ELSE  IF  CTR  -  2  THEN 

do; 

CALL  CODE$BYTE(R¥S); 

CALL  STD$ATTRIBUTES(0)J 

end; 

ELSE  CALL  PFINT$ERROR( 'IT' ) t 
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end; 

end  revrite$a$record; 

ATTRIBUTES :  PROC; 

CALL  CODE$ADDRESS(L$4DDR); 

CALL  CODE$BTTE(L$LENGTH); 

CALL  CODE$BTTE(L$DEC); 

END  attributes; 

LOAD$L*ID:  PROC(S$PTR); 

DCL  S$PTR  BITE; 

I?  ( (A$CTR  :»  PALUE(S$PTR) )  <=  NON$NUMERI C$LI T)  OR 
(A$CTR  ■  NUMERIC ^LITERAL)  THEN 

do; 

L$ADDR  -  7ALUE2(SPTR); 

L$LENGTH  -  CON$LENGTHJ 
L$TTPE  *  A$CTRJ 

If  A$CTR  -  NUfcERIC$LITERAL  THEN 
L$DEC  -  L$DEC$TEMPJ 
ELSE  L$DEC  =  0; 

RETURN ; 

end; 

IP  A$CTR  <=  LIT$2ERO  THEN 

do; 

L$TTPE,L$ADDR  =  A$CTRJ 
L$DEC  =  0; 

L$LENGTE  -  i; 

return; 

end; 

CUR$SYF.  *  VALUE(S$PTR)J 
L$TYPE  »  GET$TYPE; 

L$LENGTH  =  GET$LENGTH; 

l$dec  *  get$decikal; 

IF(L$ADDR  :»  VALUE2(S$PTR) )  =  0  THEN 
L$ADDR  »  GET$ADDRESS; 

END  load$l$id; 

LOAD$REG:  PROC (REG$NO, PTR ) ; 

DCL  (REG$NO,PTR)  BITE? 

CALL  LOAD$L$ID(PTR); 

CALL  CODE$BTTE(LOD+ARITHMETIC$TTPE); 

CALL  attributes; 

CALL  CODE$BTTE(REG$NO); 

end  loadsreg; 

STORE$REG:  PROC (PTR}; 

DCL  PTR  BYTE; 

CALL  LOAD$L$ID(PTR) J 

CALL  CODE$BYTE(STO  +  ARITHMETIC$TTPE  -  1); 

CALL  attributes; 
end  store$reg; 


STORE$CONSTANT;  PROC  ADDRESS? 

IF(MAX$INT$MEM  :=  MAX$INT$MEM  -  VARC(0))  <  NEXTAAVAILArLE 
TEEN  CALL  FATAL$ERROR( 'MO'  )  ? 

CALL  BYTE$OUT(INT)? 

CALL  ADDR$OUT{ MAX$INT$MEM) ? 

CALL  ADDR$OUT (CON  $LENGTH  :=  VARC(0))? 

DO  CTR  *  1  TO  CON$LENGTH? 

CALL  BYTE$OUT( VARC(CTR) ) ? 

END? 

RETURN  MAX$ INT$MEM? 

END  STORE$ CONSTANT? 

NUMERICHIT:  PROC  BYTE? 

DCL  CHAR  BYTE? 

L$DEC$TEMP  »  0? 

DO  CTR  8  1  TO  VARC  (0 )  ? 

IF  NOT(  DIGIT(CHAR  :=  VARC(CTR)) 

OR  (CHAR  *  '-')  OR  (CHAR  =  '•*■') 

OR  (CHAR  =  THEN  RETURN  FALSE? 

IF  CHAR  =  TEEN 

L$DFC$TEMPstVARC(  0)-CTR? 

END? 

RETURN  TRUE? 

FND  NUMERIC$LIT? 

ALPHAiLIT:  PROC  BYTE? 

DO  CTR  *  1  TO  VARC(0) ? 

IF  NOT(LETTER(VARC(CTR) ) )  THEN  RETURN  FALSE? 

END? 

RETURN  TRUE? 

END  ALPEA$LIT? 

ROUND$STORE:  PROC? 

IF  VALUE (SP )  <>  0  THEN 
DO? 

CALL  CODE$BYTE(RND) ? 

CALL  CODE$BYTE(L$DEC) ? 

END? 

CALL  STORF$REG (SP  -  1)? 

END  ROUNDSSTORE? 

ADD$SUB:  PROC (INDEX)? 

DCL  INDEX  BYTE? 

CALL  LOAD$REG(l,SP  -  1)? 

CALL  CODE$BYTE(ADD  +  INDEX)? 

CALL  ROUNDSSTORE? 

END  ADD$SUB? 

MULT$DIVi  PROC( INDEX)? 

DCL  INDEX  BYTE? 
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CALL  LOAD$REG(0,MPP1); 

CALL  L0AD$REG(1,SP  -  1); 

CALL  CODE$BYT£(MUL  +  INDEX); 

CALL  round$store; 

END  MULT$DIV? 

CHECK$SUBSCRIPT :  PROC » 

DCL  ( TEMP  fTEMP$ADDR )  ADDRESS? 

CUR$SYM  *  VALUE(MP)? 

IF  GET$TYPE  <  MULT$OCCURS  THEN 
DO? 

CALL  PRINT$ERROR('IS')? 
return; 

END? 

IF  NUMERIC$LIT  TEEN 
DO? 

TEMP$ADDR  *  GET$ADDRESS? 

IF  (TEMP  :=  GET$PREV$OCCURS)  <>  0  THEN 
CUR$SYM  »  temp; 

CALL  SET$VALUE2 

(TEMP$ADDR  ♦  (GET$LENGTH  *  (C ON VERT$ INTEGER  -  1) 

return; 

end; 

CALL  ONE$ADDR*OPP( SCR, GET$ADDRFSS ) ? 

IF  (TEMP  :*  GET$PREV$OCCURS )  <>  0  THEN 
CURSSYM  »  TEMP? 

CALL  CODE$ADDRESS(GET$LENGTH)? 
cur$stm  *  match; 

IF  ((CTR  :=  GET$TTPE)  <  NUMERIC)  OR  (CTR  >  COMP)  THEN 
CALL  PRINT$ERR0R( 'TE')? 

CALL  CODE$ADDRESS (GET$ADDRESS ) ? 

CALL  CODE$BTTE(GET$LENGTH); 

CALL  CODE$BTTE(SUB$CNT); 

CALL  SET$VALUE2(SUB$IND); 

END  check$subscript; 

LOAD$LABEL :  PROC? 

CUR$SYM  *  7ALUE(MP)| 

IF  (A$CTR  :«  GETSADDRESS)  <>  0  TEEN 
CALL  BACK$STUFF(A$CTRf7ALUE2(MP) ); 

CALL  SET$ADDRESS(VALUE2(MP) ) ? 

IF  GET$TYPE  <>  UNRESOLVED  THEN 
CALL  PRINT$ERR0R( 'DD')? 

CALL  SETiTYPE(LA?EL$TTPE); 

IF  ( A$CTR  :»  GET$FCB$ADER)  <>  0  THEN 

CALL  BACX$STUFP( A$CTR, NEXT$ AVAILABLE ) ? 

SYMBOL$ADDR (FCB$A  DDR)  >  NEXT$AVA ILABLEJ 
CALL  ONE$ADDR$OPP(RET,0); 

END  LOAD$LABFL? 


LOAD$SEC$LABEL:  PROC? 


A$CTR  *  VALUE (MP)? 

CALL  SET$VALUE(EOLD$SECTION)? 

HOLDiSECTION  »  A$CTR? 

A$CTR  -  VALUE2 (MP) ? 

CALL  SET$VALUE2(H0LD$SEC$ADDR)? 

HOLD$SEC$ADDR  *  A$CTR? 

CALL  loadhabel? 
end  load$sec$label; 

LABEL$ADDR$OFFSET:  PROC  (ADDR,  HOLD,  OFFSET)  ADDRESS? 
DCL  ADDR  ADDRESS? 

DCL  (SOLD,  OFFSET,  CTR)  BYTE? 

C0R$SYM  -  ADDR? 

IF(CTR  :»  GET$TYPE)  =  LABEL$TYPE  THEN 
DO? 

IF  HOLD  THEN  RETURN  GET$ADDRESS  ? 

RETURN  GET$FCB$ADDR? 

END? 

IF  CTR  <>  UNRESOLVED  THEN  CALL  INVALID$TYPE? 

IF  HOLD  THEN 
DO? 

A$CTR  =  GET$ADDRESS ? 

CALL  SET$ ADDRESS (NEXTSAVAILABLE  +  OFFSET)? 
RETURN  A$CTR? 

END? 

A$CTR  =  GET$FCB$ADDR? 

STMBOL$ADDR ( FCB$ADDR )  »  NEXT$AVA ILABLE  +  OFFSET? 
RETURN  A$CTR? 

END  LABEL$ADDR$OFFSET? 

LABEL$ADDR:  PROC  (ADDR,  HOLD)  ADDRESS? 

DCL  ADDR  ADDRESS, 

HOLD  BYTE? 

RETURN  LABEL$ADDF$OFFSET  (ADDR,  HOLD,  1)? 

END  LABEL$ADDR? 

CODE$FOR$DISPLAY :  PROC  (POINT)? 

DCL  POINT  BYTE? 

CALL  load$l$id(point); 

CALL  ONE$ADDR$OPP(DIS,L$ADDR)? 

CALL  CODE$BYTE(L$LENGTH) ? 

IF  DISPLA Y$FLAG  THEN  CALL  CODE$BYTE(l ) ? 

ELSE  CALL  COIS$BYTE(0) ? 

DISPLAY$FLAG  «  FALSE? 

END  CODE$FOR$DI SPLAY? 

A$AN$TYPE:  PROC  BYTE? 

RETURN  (L$TYPE  >-  ALPHA)  AND  ( L$TYPE  <*  LIT$QUOTF) 
END  A$AN$TYPE  ? 


NOT$INTECER:  PROC  BYTE? 


RETURN  L$DEC  <>  0J 

end  not$integer; 

NUMERIC$TYPE:  PROC  BYTE? 

RETURN  ( (L$TYPS  >*  NUMERIC $LITERAL)  AND  ( L$TY PE  <=  COMP)) 
OR  (L$TYPE*LIT$ZERO ) » 

END  NUMERIC$TYPEJ 

GEN $ COMPARE:  PROC; 

DCL  (H$TYPE ,H$DEC )  BYTE, (H$ADDR ,H$LENGTH)  ADDRESS; 

CAU  LOAD$L$  ID  (MP ) ; 

L$TYPE  «  AND$OUT$OCCURS(L$TYPE); 

IP  COND$TYPE  *  3  THEN  /*  COMPARE  FOR  NUMERIC  */ 

do; 

IP  L$TYPE  *  ALPHA  OR  (L$TYPE  >  COMP)  THEN 

CALL  invalid$type; 

CALL  SET$7ALUE2(NEZT$AVAILABLE); 

IP  L$TYPE  *  NUMERIC  TEEN  CALL  CODE$BYTE( CNU ) ; 

ELSE  CALL  CODE$BYTE(CNS)j 
CALL  CODE$ADDRESS(L$ADER); 

CALL  CODE$ADDRESS(L$LENGTH); 

call  set$branch; 

end; 

ELSE  IP  COND$TYPE  »  4  THEN 

do; 

IP  NUMERIC$TYPE  THEN  CALL  INPALID$TYPE; 

CALL  SET$YALUE2(NEXT$AVAILABLE); 

CALL  CODE$BYTE(CAL); 

CALL  CODE$ADDRESS ( L$ ADDR  )  i 
CALL  CODE$ADDRESS(L$LENGTH); 

CALL  set$branch; 
end; 

ELSE  do; 

IP  NUMERIC$TYPE  THEN  CTR=1J 
ELSE  CTR  =0; 

H$TYPE  *  L$TYPEJ 
H$DEC  «  L$DECJ 
R$ADDR  =  L$ADDR! 

HUENGTH  «  L$LENGTH; 

CALL  LOAD$L$IV(SP); 

IP  NUMSRIC$TYPE  THEN  CTR  *  CTR  ♦  1J 
IP  CTR  ■  2  THEN  /*  NUMERIC  COMPARE  */ 

do; 

CALL  LOAD$REG(0,MP); 

CALL  SET$VALUE2( NEIT$AVAILABLE  -  6); 

CALL  LOAD$REG(l,SP) 5 
CALL  CODE$BYTS(SUB); 

CALL  CODE$BYTE(RGT  ♦  COND$TYPE) * 

call  set$branch? 
end; 
else  do; 
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/*  ALPHA  NUMER1*  COMPARE  */ 

IT  (ESTYPE  »  COMP)  OR  (L$TYPE  =  COMP)  THEN 

CALL  invalidstype; 

ELSE  IF  (HHENSTE  <>  L$LENGTH)  THEN 
IF  NOT  ( (L$TYPE  >»  LIT$SPACE)  AND 
(L$TTPE  O  LIT$ZERO ) )  XOR 
( (H$TTPE  >*  LIT$SPACE)  AND 
(HSTYPE  <=  LIT$ZERO ) )  THEN 
CALL  INVALID$TYPE; 

ELSE  IP  (L$DEC  <>  0)  OR  (H$DEC  <>  0)  THEN 
IF  NOT  ( (L$TYPE  =  NUMSED)  XOR 
( H$TYPE  =  NUMSED) )  THEN 
CALL  IN7ALID$TYPEJ 
CALL  SET$VALUE2(NEXT$A7AlLABLE)t 
CALL  CODES BY TE(SGT+COND$TYPE ) » 

CALL  CODESADDRESS ( H$ADDR  ) » 

CALL  CODE$ADDRESS(L$ADDR); 

CALL  CCDESADDRESS(HSLENGTE); 

CALL  setsbranch; 

end; 

end; 

end  gen$compare; 

MOVESTYPF i  PROC  BYTE; 

DCL 

HOLDSTYPE  BYTE, 

ALPEA$NUM$MOYE 
A$N$ED$MOVE 
NUMFRICSMOVE 
N$ED$MOYE 
L$TYPE  »  ANE$OUT$OCCORS(L$TYPE); 

IF( (HOLDSTYPE  :»  AND$OUT$OCCURS(GFT$TYPE) )  =  GROUP)  OR 
(LSTYPE  »  GROUP) 

THEN  RETURN  ALPHA$NUM$MOVE; 

IF  HOLDSTYPE  «  ALPHA  THEN 

IF  A$AN$TYPE  OR  (LSTYPE  =  ASED)  OR  (LSTYPE  =  ASM$ED 
OR  ( (ALPHA$LIT$FLAG )  AND 
(LSTYPE  »  NON  $NUMERIC$LIT  ) ) 

THEN  RETURN  ALPHA$NUM$MOVE; 

IF  HCLDSTTPE»ALPBA$NUM  THEN 

do; 

IF  NOTSINTEGER  AND  (LSTYPE  <>  NUMSED)  THEN 

call  inyalidstype; 

RETURN  ALPHASNUMSMOYE; 

end; 

IF  (HOLDSTYPE  >«  NUMERIC)  AND  (HOLDSTYPE  COMP)  THEN 

do; 

IF  (LSTYPE  •  ALPHA)  OR  (LSTYPE  >  COMP)  THEN 

CALL  inyalidstype; 

RETURN  NUMEPICSMOYE; 

end; 


LIT  '0', 
LIT  '1', 
LIT  '2', 
LIT  '3'? 
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IF  HOLD$TYPE  -  A$N$ED  THEN 

do; 

IF  NOT$INTEGER  AND  ( L$TTPE  <>  NOM$ED)  THEN 
CALL  INVALID$TTPE5 
RETORN  A$N$ED$MOVE; 

end; 

IF  HOLD$TT?E  *  A$ED  THEN 

IF  A$AN$TYPE  OR  (L$TYPE  >  COMP)  OR 
(L$TYPE  =  N ON  $N UMER I C $  LI T ) 

THEN  RETURN  A$N$ED$MOYE » 

IF  HOLD$TTPE  »  NUMAED  THEN 

I?  NUMERIC$TTPE  OR  (L$TYPE  =  ALPHA $NOM)  THEN 
RETURN  N$ED$MOVE» 

CALL  invalid$type; 

RETURN  0; 

END  move$type; 

GEN $MOVE: PROC ; 

DCL  (ADDR1, EXTRA, LENGTHl)  ADDRESS; 

ADD$ADD$LEN :  PROC; 

CALL  CODE$ADDRESS ( ADDR1 )  J 
CALL  CODE$ADDRESS(L$ADDR) ; 

CALL  C0DE$ADDRESS(L$LENGT3)J 

END  add$add$len; 

CODE$?OR$EDIT:  PROC; 

CALL  add$add$len; 

CALL  CODE$ADDRESS(GET$FCB$ADDR); 

CALL  CODE$ADDRESS(LENGTHl) ; 

END  code$for$edit; 

CALL  LOAD$L$ID(MPPl); 

CUR$SYM*YALUE(SP); 

IF  (ADDR1  :»  VALUE2(SP) )  *  0  THEN  ADDR1  »  GET $ADDRESS 
LENGTH1  ■  GET$LENGTH; 

do  case  move$type; 

/*  ALPHA  NUMERIC  MOVE  V 

do; 

IF  LENGTH1  >  L$LENGTH  THEN 

EXTRA  =  LENGTH  1  -  L$LENGTHJ 
ELSE  do; 

EXTRA  =  0; 

L$LENGTH  -  LENGTH1  \ 

end; 

CALL  CODE$BYTE(MOV); 

CALL  add$add$len; 

CALL  CODE$ADDRESS( EXTRA); 

end; 

/*  ALPHA  NUMERIC  EDITED  V 

do; 


CALL  CODE$BYTE(MSD); 

CALL  code$for$edit; 

end; 

/*  NUMERIC  MOVE  */ 

do; 

CALL  LOAD$REG (2 ,MPP1 ) » 

CALL  STORE$REG(SP); 

end; 

/*  NUMERIC  EDITED  MOVE  */ 

DO? 

CALL  C0DE$3ITE(MNE),* 

CALL  code$for$edit; 

CALL  CODE$BYTE(L$DEC); 

CALL  CODE$BYTE(GET$DFCIMAL); 

end; 

end; 

end  gen$move; 

CODE$GEN:  PROC (PRODUCTION ) } 

DCL  PRODUCTION  BYTE; 

IF  PRINT$PROD  THEN 

do; 

call  crlf; 

CALL  PRINTCHAR(POUND); 

CALL  PRINT$NUMBER(PRODUCTlON); 

end; 

DO  CASE  production; 

/*  PRODUCTIONS*/ 

;  /*  CASE  0  NOT  USED  */ 

/*  1  <P-DIV>  =  PROCEDURE  DIVISION  <USING>  .  */ 

/*  1  <PROC-BODY>  V 

do; 

COMPILING  =  FALSE; 

IF  SECTION$FLAG  THEN  CALL  LOAD$SEC$LABEL; 

end; 

/*  2  <USING>  s:=  USING  <ID-STRING>  */ 

IF  VALUE (MP  -  1)  *  0  THEN 
DO  I  »  0  TO  id$ptr; 

CURSYM  »  id$stack(i); 

CALL  SET$ADDRESS ( 13  +  1)5 

end; 

ELSE 

do; 

CALL  CODE$BYTE(PAR); 

CALL  CODE$ADDRESS(ID$PTR  +1); 

DO  I  «  0  TO  id$ptr; 

CURSSYM  -  ID$STACK( I ) J 

CALL  CODE$ADDRESS(GET$ ADDRESS  ) ; 

end; 

end; 

/*  3  \!  <EMPTY>  */ 
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J  /*  NO  ACTION  REQUIRED  */ 

/*  4  <ID-STRING>  ::  =  <ID>  V 

ID$STACK( ID$PTR  :  =  0)  =  VALUE(SP); 

/*  5  \ !  <ID-STRING>  <ID>  */ 

do; 

IF(ID$PTR  :  =  IDPTR  +1)  =20  TEEN 

do; 

CALL  PRINT$ERROR(  'ID')  > 

ID$PTR=19i 

end; 

ID$STACE(ID$PTR)=VALUE(SP); 

end; 


/* 

6 

<PROC-BODT>  ::  =  <PARAGRAPH> 

*/ 

• 

f 

/* 

NO  ACTION  REQUIRED  */ 

/* 

7 

\ !  <PROC-BODT>  <PARAGRAPE> 

*/ 

• 

f 

/* 

NO  ACTION  REQUIRED  */ 

/* 

8 

<PARAGRAPH>  ::=  <ID>  . 

*/ 

• 

f 

/* 

NO  ACTION  REQUIRED  */ 

/* 

do; 

9 

\ !  <ID>  .  <SENTENCE-LIST> 

V 

IF  SECTION$FLAG  =  0  THEN  SECTION$FLAG  =  2f 


call  load$lapel; 

end; 

/*  10  \ !  <ID>  SECTION  .  */ 

do; 

IF  SECTION $FLAG<>1  THEN 

do; 

IF  SECTION$FLAG  =  2  THEN 
CALL  PRINTS ERROR ( 'PF' ) ; 

SECTION $FLAG  =  1$ 

HOLDSSSCTION  =  VALUE (MP  ) ; 

HOLD$SEC$ADDR  =  VALUE2(MP); 

end; 

ELSE  CALL  LOAD$SEC$LABEL; 

end; 

/*  11  <SENTENCE-LIST>  ::=  <SENTENCE>  .  */ 

CALL  chk$nxt$sentence; 

/*  12  \ I  <SENTENCE-LIST>  */ 

/*  12  <SFNTENCE>  .  */ 

call  chk$nxt$sentence; 

/*  13  <SENTENCE>  :  :=  <IMPERATIVE>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  14  \!  <CONDITIONAL>  V 

;  /*  NO  ACTION  REQUIRED  */ 

/*  15  \!  ENTER  <ID>  <OPT-ID>  */ 

CALL  PRlNT$ERROR(  'NI ' ) 5 

/*  16  <IMPERATIVE>  ::=  ACCEPT  <SUBID>  */ 

do; 

CALL  LOAD$L$ID(SP)i 

CALL  ONE$ADDR$OPP(ACCvL$ADDR); 

CALL  CODESBTTE(LSLENGTH); 


i 
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end; 

/*  1?  \!  <APITHMETIC>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

/*  18  \!  CALL  <CALL~LIT>  <USING>  */ 

do; 

CURSYM  =  VALUE (MPP1); 

CALL  CODE$BTTE(SBR); 

do  i  *  i  to  e; 

IF  I  <=  GET$P$LENGTH  THEN 

CALL  BYTE$OUT(SYMBOL(START$NAME  +  I))J 
ELSE  CALL  BYTE$OUT(20H ) J 

end; 

CALL  INC$C0UNT(6); 

end; 

/*  19  \!  CLOSE  <CLOSE-LS?>  */ 

do; 

DCL  TYPE  BYTE; 

IE  ((TYPE  :=  GET$TYPE)  >  0)  AND  (TYPE  <  5)  THEN 
CALL  ONE$ADDR$OPP( CLS ,GST$FCB$ADDR ) J 
ELSE  CALL  PRlNT$ERROR( 'CE '  ) ; 

end; 

/*  19  \!  <FILE-ACT>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  21  \!  DISPLAY  <DISPLAY-LST>  */ 

,*  /*  NO  ACTION  REQUIRED  */ 

/*  22  \!  DISPLAY  <DISPLAY-LST>  WITH  */ 

/*  22  NO  ADVANCING  */ 

;  /*  NO  ACTION  REQDIRED-NOT  IMPLEMENTED  V 

/*  23  \!  EXIT  <PROGRAM-ID>  */ 

CALL  CODE$BYTE(EXT); 

/*  24  \!  GO  <ID>  V 

CALL  ONEiADDR$OPP(BRN,LABEL$ADDR(VALUE(SP) ,1) ); 

/*  25  \!  GO  <ID-STRING>  DEPENDING  */ 

/*  25  <ID>  V 

do; 

CALL  CODE$BTTE(GDP); 

CALL  CODE$BYTE( ID$PTR  +1); 

CUR$SYM  »  VALUE(SP); 

CALL  CHK$UD$VAR(SP); 

CALL  CODE$BYTE(GET$LENGTH); 

CALL  CODE$ADDRESS(GET$ADDRESS  ); 

DO  CTR  «  0  TO  IDSPTRJ 
CALL  CODE$ADDRESS 

(LABEL$ADDR$OFESET( ID$STACX (CTR)  ,1 ,0) ) J 

end; 

end; 

/*  26  \!  MOVE  <LIT/ID>  TO  <SU3ID>  */ 

CALL  gen$move; 

/*  27  \!  OPEN  <ACT-LST>  */ 

J  /*  NO  ACTION  REQUIRED  V 

/*  28  \J  PERFORM  <ID>  <THRU>  <FINISH>*/ 


_ ^ 

ii Mirtrmii  iiirn  ■  hiiTf 
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ro; 


DCL  (ADDR2  ,AEER3)  ADDRESS * 

IF  VALUE (SP  -  1)  ■  0  THEN 

ADDR2  =  L ABEL $ADDR$ OFFSET (VALUE (MPP1 ) ,0 ,3 )  ? 

ELSE  ADEP2  -  L A  PEL $ADDR $ OFFS ET ( VALUE ( SP-1 ) , 0 ,3) » 

IF  ( ADDR3  :*  VALUE2(SP))  =  0  THEN 
ADDR3  =  NEXT$AVAILABLE  +  7? 

ELSE  CALL  BACKSTUFF (VALUE (SP ) .NEXT SAVA ILAPLF  ♦  7) » 
CALL  ONE$ADDR$OPP(PER,LABEL$ADDR(VALUE(MPPl)  ,1)): 

CALL  COEE$ADDRESS ( AEER2 ) > 

CALL  CODF$ADDRESS (ADDR3)  * 

end; 

/*  29  \ !  STOP  <TSRMINATE>  */ 

do; 

IF  VALUE ( SP )  =  0  THEN  CALL  CODE$BYTE(STP) ; 

ELSE  IF  (VALUE(SP)  <  LIT$SPACE)  OR 
(VALUE ( SP )  >  LITSZERO)  THEN 

do; 

CALL  ONE$ADDR$OPP ( STD  ,VALUE2( SP ) ) ; 

|  CALL  CODE$BYTE( CON $ LENGTH ) J 

end; 

ELSE 

do; 

CALL  ONESADDR$OPP(STD,VALUE(SP)); 

CALL  CODE$BYTE(l); 

end; 

end; 

/*  30  <CLOSE-LST>  <ID>  V 

;  /*  NO  ACTION  REQUIRED  */ 

/*  31  \ !  <CLOSE-LST>  <ID>  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

/*  32  <DISPLAY-LST>  ; :=  <LIT/ID>  */ 

CALL  CODE$FOR$DISPLAY(SP); 

/*  33  \!  <DISPLAY-LST>  <LIT/ID>  */ 

do; 

DISPLAYS FLAG  =  TRUE; 

CALL  CODESFOR$DISPLAT(S?) ; 

END? 

/*  34  <ACT-LST>  <TYPE-ACTION>  <OPEN-LST>  */ 

do; 

DCL  TYPE  BYTE; 

TYPE  =  get$type; 

if  (TYPE  =  1  OR  TYPE  =  4)  AND  (VALUE(MP)  <>  2)  THEN 
CALL  ONE$ADDR$OPP(OPN  +  VALUE(MP) , GETSFCBSADDR ) ; 

ELSE 

IF  (TYPE  -  2  OR  TYPE  *  3)  THEN 

CALL  ONE$ADDR$OPP( OPN  +  VALUE (MP) tGET$FCB$AEDR ) ; 
ELSE  CALL  PRINT$ERROR( 'OE' ) ; 

end; 


/*  35  \ !  <ACT-LST>  <TYPE-ACTION>  */ 

/*  35  <OPEN-LST>  */ 
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•  /# 

NO  ACTION  REQUIRED-NO?  IMPLEMENTED  */ 

/* 

36 

<OPEN-LST>  <ID> 

*/ 

:  /* 

NO  ACTION  REQUIRED  */ 

/* 

37 

\ !  <OPEN-LST>  <ID> 

*/ 

•  /# 

NO  ACTION  REQUIRED-NOT  IMPLEMENTED  V 

/* 

3e 

<FIN ISH>  <L/ID>  TIMES 

*/ 

do; 

CALL 

LOAD$L$ID{MP) 5 

CALL 

ONE$ADDR$OPP(LDI ,L$ADDR) ; 

CALL 

CODE$BTTE(L$LENGTH) ; 

CALL 

SET$VALUE2(NEIT$AVAILA3LE); 

CALL 

CNE$ADDR$OPP(DEC,0) ; 

CALL 

SET$VALUE(NEXT$AVAILABLF) J 

CALL 

CODE$ADDRESS ( 0) ; 

end; 

/* 

39 

\ I  <STOPCONDITION> 

*/ 

CALL  KEEP$VALUES; 

/* 

40 

\ !  <VARYINC>  ^ITERATION > 

*/ 

/* 

40 

<STOPCONDITION> 

*/ 

CALL  KEEP$VALUESJ 

/* 

41 

\ !  <EMPTY> 

*/ 

;  /* 

NO  ACTION  REQUIRED  */ 

/* 

42 

<STOPCONDITION>  ::=  UNTIL  <CONDITION> 

*/ 

CALL  KEEP$VALUES; 

/* 

43 

<VARYING>  VARYING  <SUBID> 

*/ 

CALL  KEEP$VALOES; 

/* 

44 

<ITERATION>  <EROM>  <BY> 

*/ 

;  /* 

NO  ACTION  REQUIRED  */ 

/* 

45 

<EROM>  FROM  <L/ID> 

*/ 

do; 

CALL  L0AD$REG(2,SP); 

CALL  STORE$REG(MP  -  l)i 

end; 

/* 

46 

<BY>  BY  <L/ID> 

*/ 

do; 

CALL  LOAD$REG(0fMP  -  2); 
CALL  LOAD$RFG(ltSP); 

CALL  CODE$BYTE(ADD); 

CALL  STORE$RSG(MP  -  2); 

END; 


/* 

47  <CONDITIONAL> 

•  •  s 

•  • 

<ARITHMETIC>  <SIZE-FRRCR> 

*/ 

/* 

47 

CALL  back$cond; 

<IMPERATIVE> 

*/ 

/* 

48 

\! 

<FILE-ACT>  <INVALID> 

V 

/* 

48 

call  back$cond; 

<IMPERATIVE> 

*/ 

/* 

49 

\! 

<READ-ID>  <SPECIAL> 

*/ 

/* 

49 

call  bace$cond; 

<IMPERATIVE> 

*/ 

/* 

50 

\! 

<IF-N ONTERMIN AL> 

V 

/* 

50 

<CONDITION>  <IF-LST>  <ELSE>*/ 
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f 


50 


<IF-LST>  END-IP 


/* 


/* 

/* 

/* 

/* 

/* 


/* 


/* 

/* 

/* 

/* 


/* 

/* 

/* 

/* 

/• 

/* 

/• 

/* 

/* 

/* 

/* 

/* 

/• 

/* 


do; 

CALL  BACKSTUFF(VALUE{MPP1),VALUE2(SP  -  3)); 
CALI  BACKS TUFF ( VALUE( SP  -  3) ,NEXTSAVAILABLF) » 

end; 

51  \ !  <IF-NONTERMINAL> 

51  <CONDITION> 

51  <IF-LST>  END-IF 
CALL  BACKSTUFF( VALUE (MPP1) ,  NEXTSAVAILABLE  ) ; 

52  <IF-LST>  <STMT-LST> 

;  /*  NO  ACTION  REQUIRED  */ 

53  \ !  NEXT  SENTENCE 


V 


*/ 

*/ 

*/ 

*/ 

*/ 


do; 

CALL  ONE$ADDR$OPP(BRNfNEXT$ADDP.ESS) ; 

NEXT$ADDRESS  *  NEXTSAVAILABLE  -  2i 

end; 

54  <ELSE>  s :*  ELSE  */ 

do; 

VALUE( SP  -  1)  =  NEXT$AVAILABLE  ♦  1J 
CALL  ONE$ADDR$OPP(BRN,0); 

VALUE2 (SP  -  1)  «  nextsavailable; 

end; 

55  <ARITHMETIC>  ADD  <ADD-LST>  TO  <SUBID>  */ 

55  <ROUND>  ♦/ 

CALL  ADDS  SUB  (0),* 

56  \!  ADD  <ADD-LST>  GIVING  <SUBID>*/ 

56  <ROUND>  */ 


do; 

IF  VALUE (MP)  *  0  THEN  CALL  PRINT$ERROR( 'IG' ) J 
CALL  roundsstore; 

end; 


57 

57 

CALL  MULTSDIV(l); 

58 

58 

CALL  PRINT$ERROR( 'NI'); 

59 

CALL  PRINTS ERROR( 'N I ' ) ; 

60 
60 

CALL  MULT$DIV(0 ); 

61 

61 

CALL  PRINT$ERROR(  'HI ' ) ; 
62 
62 

CALL  ADDSSUB(l); 

63 

63 


\!  DIVIDE  <L/ID>  INTO  <SUBID> 
<ROUND> 

\J  DIVIDE  <L/ID>  BY  <SU?ID> 
GIVING  <SUBID>  <ROUND> 

\!  DIVIDE  <L/ID>  INTO  <SUBID> 
GIVING  <SUBID>  <ROUND> 

\!  MULTIPLY  <L/ID>  BY  <SUBID> 
<ROUND> 

\ !  MULTIPLY  <L/ID>  BY  <SUPID> 
GIVING  <SUBID>  <ROUND> 

\ l  SUBTRACT  <SUB-LST>  FROM 
<SUBID>  <ROUND> 

\ !  SUBTRACT  <SUB-LST>  GIVING 
<SUBID>  <ROUND> 


*/ 

*/ 

*/ 

*/ 

*/ 

*/ 


*/ 

*/ 

V 

*/ 

V 

*/ 

*/ 

*/ 


-  ~ . - . --  ■  - — 
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IF  VALUE  (MP )  =  0  THEN  CALL  PRINT$ERROR  ( 'IG' )  * 

CALL  round$store; 

end; 

64  \ !  COMPUTE  <SUBID>  =  <ARI TH-EXP>*/ 
CALL  PRINT$ERROR(  'NI ' ) ; 

65  <ADD-LST>  =  <L/ID>  */ 

CALL  LOAD$REG(0»SP) » 

66  \l  <ADD-LST>  <L/ID>  */ 

do; 

CALL  LOAD$REC(l,SP); 

CALL  CODE$BYTE(ADD); 

CALL  CODE$BTTE(STI); 

VALUE (MP  -  1)  ■  i; 

END % 

*67  <SUB-LST>  =  <L/ID>  */ 

CALL  LOAD$REG(0,SP)J 

68  \!  <SUB-LST  <L/ID>  */ 

do; 

CALL  LOAD$REG(l,SP); 

CALL  CODE$BYTE(ADD)J 
CALL  CODE$BYTE(STI); 

VALUE (MP  -  1)  -  1J 

end; 

69  <ARITH-EXP>  =  <TERM>  V 

J  /*  NO  ACTION  REOUIRED-NOT  IMPLEMENTED  */ 

70  \J  <ARITH-EXP>  ♦  <TERM>  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

71  \!  <ARITH-EXP>  -  <TERM>  */ 

;  /*  NO  ACTION  REQUIRED-HOT  IMPLEMENTED  */ 

72  \ I  +  <TERM>  */ 

?  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

73  \!  -  <TERM>  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

74  <TERM>  <PRIMARY>  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

75  \!  <TERM>  *  <PPIMARY>  »/ 

;  /*  NO  ACTION  REOUIRED-NOT  IMPLEMENTED  */ 

76  \ !  <TERM>  /  <PRIMARY>  */ 

i*  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  V 

77  <PRIMARY>  =  <PRIM-ELEM>  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

78  \!  <PHIMARY>  **  <PRIM-ELEM>  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

79  <PRIM-ELEM>  <L/ID>  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

80  \ !  (  <ARITH-EXP>  )  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

81  <?ILE-ACT>  :s*  DELETE  <ID>  */ 

call  delete$a*file; 

82  \!  REWRITE  <ID>  */ 


/* 

/* 

/* 

/* 

/* 

/* 

/* 


/* 

/* 

/* 

/* 

f* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 


CALL  RE¥RITE$A$RECORD; 

83  \ !  WRITE  <ID>  <SPEC I AL-ACT>  */ 

CALL  WRITER A $RECORD; 

84  <CONDITION>  =  <BTERM>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

85  \I  <C0NDITI0N>  OR  <BTERM>  */ 

J  /»  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

86  <BTERM>  <BPRIM>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

87  \!  <BTERM>  AND  <BPIRM>  */ 

J  /*  NO  ACTION  REQUIRED-NOT  IMPLEMETED  V 

88  <BPRIM>  <LIT/ID>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

89  \!  <LIT/ID>  <NOT>  <COND-TTPE>  V 

do; 

IF  IF$FLAO  THEN 

do; 


IF$FLAG  =  NOT  IF$FLAG;  /*  RESET  IF$FLAG  */ 


CALL  CODE$BTTE(NEG); 

end; 

CALL  gen$compare; 

end; 

90  \!  (  <BTERM>  )  */ 

;  /*  NO  ACTION  REQUIRED-NOT  IMPLEMENTED  */ 

91  <COND-TYPE>  =  NUMERIC  V 

COND$TYPE  *  3; 

92  \!  ALPHABETIC  */ 

COND$TTPE  *  4J 

93  \ !  <COMPARE>  <LIT/ID>  */ 

CALL  EEEP$VALUES; 

94  <NOT>  NOT  V 

IF  NOT  IF$FLAG  THEN 

CALL  CODE$BTTE(NEG); 

ELSE  IF$FLAG  »  NOT  IF$FLAG J  /*  RESET  IFSFLAG  */ 

95  \!  <EMPTY>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

96  <COMPARE>  GREATER  */ 

CONB$TYPE  »  05 

97  \ 1  LESS  */ 

COND$TYPE  =  i; 

98  \I  EQUAL  V 

CONDSTYPE  *  2; 

99  \!  >  */ 

COND$TYPE  «  0; 

100  \ !  <  */ 

COND$TYPE  »  l; 

101  \ !  -  */ 

COND$TYPE  «  2; 

102  <ROUND>  ROUNDED  */ 

CALL  SET$YALUE(1); 

103  \ !  <EMPTY>  */ 
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5  /*  MO  ACTION  REQUIRED  */ 

/*  104  <TERMINATE>  : :  =  <LITERAL>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

/*  105  \ !  RUN  */ 

;  /*  NO  ACTION  REQUIRED  -  VALUE (SP)  ALREADY  ZERO  V 

/*  106  <SPECIAL>  <INVALID>  */ 

?  /*  NO  ACTION  REQUIRED  */ 

/*  107  \!  END  V 

do; 

CALL  SST$VALUE(2); 

CALL  CODE$5YTE(EOR) » 

CALL  set$branch; 

end; 

/*  108  <OPT-ID>  <SUBID>  */ 

J  /*  VALUE  ANT  VALUE2  ALREADY  SET  */ 

/*  109  \I<E^PTY'>  */ 

J  /*  VALUE  ALREADY  ZERO  */ 

/*  110  <STMT-LST>  =  <IMPERATIVE>  */ 

;  /*  NO  ACTION  REQUIRED  V 

/*  111  \J  <STHT-LST>  <IMPERATIVE>  */ 

;  /*  NO  ACTION  REQUIRED  V 

/*  112  \!  <CONDITIONAL>  V 

i  /*  NO  ACTION  REQUIRED  V 

/*  113  \t  <STMT-LST>  <CONDITIONAL>  ♦/ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  114  <THRU>  s :*  THRU  <ID>  */ 

CALL  KEEP$VALUES; 

/*  115  \!  <EI"PTr>  V 

;  /*  NO  ACTION  REQUIRED  */ 

/*  116  <IN VALID>  INVALID  */ 

do; 

CALL  SET$VALUE(l)i 
CALL  CODE$BYTE(INV); 

CALL  set$branch; 

end; 

/*  117  <SIZE-ERROR>  SIZE  ERROR  */ 

do; 

CALL  CODE$BYTE(SER); 

CALL  unres$branch; 

end; 

/*  lie  <SPECIAL-ACT>  <WHEN>  ADVANCING  <HOW-KANY>  */ 


CALL  KEEP$VALUES;  /*  CARRAGE  CONTROL  */ 

/*  119  \ !  <EKPTY>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  120  <WHEN>  s:«  BEEORE  */ 

WRITE$BE?ORE  -  TRUE?  /*  CARRAGE  CONTROL  */ 

/*  121  \!  AFTER  */ 

VRITE$A?TER  ■  TRUE;  /*  CARRAGE  CONTROL  */ 

/*  122  <H0W-MANY>  <INTEGER>  */ 

?  /*  NO  ACTION  REQUIRED  */ 

/*  123  \l  PAGE  */ 
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CALI  STT$VALUE(101);  /*  CABBAGE  CONTROL  */ 

124  <TTPE-ACTION>  INPUT 

;  /*  NO  ACTION  BEQDIBED  -  VALUE(SP)  ALBEADT  ZEBO  */ 

125  \!  OUTPUT 

CALL  SET$7ALUE ( 1 ) * 

126  \I  1-0 

CALL  SET$VALUE(2)J 

127  <SUBID>  <SUBSCHIPT> 

J  /*  VALUE  AND  VALUE2  ALBEADT  SET  */ 

128  \!  <ID> 

CALL  CHX$UD$?AR(SP) » 

129  <INTEGEB>  <INPUT> 

CALL  SET$VALUE(CONVEBT$INTEGEB); 

130  CIO  <INPUT> 
do; 

CALL  SET$VALUE(KATCH)J 
IE  GET$TYPE  «  UNBESOLVED  THEN 

CALL  SET$VALUE2(NEXT$AYAILABLE); 

end; 

131  <L/ID>  <INPUT> 

do; 

IF  NUf“!ERIC$LIT  THEN 

do; 

CALL  SET$VALUE(NUMEBIC$LITEBAL); 

CALL  SET$ VALUE2( STOBE$CONSTAN T ) i 

end; 

ELSE 

do; 

CALL  SET$VALUE(MATCH)5 
CALL  CHX$UD$VAH(MP); 

end; 

end; 

132  \ !  <SUBSCRIPT> 

;  /*  NO  ACTION  REQUIRED  */ 

133  \!  ZERO 
CALL  SET$VALUE(LIT$ZERO); 

134  <SUBSCBIPT>  <ID>  (  <SUBSCRIPT-LST>  ) 

CALL  checi$subscript; 

135  CSUBSCBIPT-LSO  <INPUT> 

;  /*  NO  ACTION  REQUIRED  */ 

136  \ !  CSUBSCB IPT-LST>  ,  <INPUT> 
CALL  PRINT$ERR0R( 'N I ' ) ; 

137  <CALL-LIT>  s:»  <LIT> 

CALL  SET$VALUE(P'ATCH)  i 

138  <NN-LIT>  si-  <LIT> 

do; 

alpha$lit$flag  -  alpha$lit; 

CALL  SET$VALUE(NON$NUHEBIC$LIT); 

CALL  SST$VALUE2(ST0PE$C0NSTANT) ; 

end; 

139  \ I  SPACE 
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CALL  SET$VALU£{LIT$SPACE ) » 

/*  140  \ !  QUOTE  */ 

CALL  set$value(lit$quote); 

/*  141  <LITERAL>  <NN-LIT>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  142  \!  <INPUT>  */ 

do; 

IE  NOT  NUMERICHIT  THEN  CALL  INVALID$TYPEJ 
CALL  SET$VALUE(NUMERIC$ LITERAL ) * 

CALL  SET$VALUE2(STORE$CONSTANT); 

end; 

/*  143  \ !  ZERO  ♦/ 

CALL  SET$VALUE(LIT$ZERO); 

/*  144  <LIT/ID>  <L/ID>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  145  \ !  <NN-LIT>  *7 

;  /*  NO  ACTION  REQUIRED  */ 

/*  146  <PROGRAM-IE>  <IL>  */ 

CALL  CODE$BTTE(EXT); 

/*  14?  \ !  <EMPTY>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  148  <READ-ID>  =  READ  <ID>  V 

CALL  READ$A$FILE; 

/*  149  <  I F-N  ON  TERMINAL'*  :  IF  */ 

I?$FLAS  »  TRUE;  /*  SET  IF$FLAG  */ 

END?  /*  END  OF  CASE  STATEMENT  */ 

END  code$gen; 

GETIN1:  PROC  ADDRESS  > 

RETURN  INDEZ1  (STATE)* 

END  GETINi; 

GETIN2:  PROC  BYTE; 

RETURN  INDEX2 (STATE); 

END  GETIN2; 

INCSPs  PROC; 

VALUE (SP  :*  SP  ♦  1),VALUE2(SP)  »  0}  /*  CLEAR  TIE  STACK  */ 
IF  SP  >«  PSTACKSIZE  THEN  CALL  FATAL$ERROR (  'SO ') » 

END  INCSP; 

LOOKAHEAD:  PROC! 

IF  NOLOOK  THEN 

do; 

call  scanner; 
nolook  -  false; 

IF  PRINT$TOKEN  THEN 

do; 

call  crlf; 

call  print$number(token); 

CALL  PRINT$CHAR( '  ')? 


CALI  PRINT$ACCUMJ 

end; 

end; 

end  lookahead; 

NO$COSTL ICT:  PROC  (CS TATE)  BTTE; 

DCL  ( CSTATE ,  I , J  ,K  )  ADDRESS; 

J  =  INDEXl(CSTATE); 

K  =  J  ♦  INDEI2(CSTATE)  -  l; 

DO  I  -  J  TO  k; 

IF  READl(I)  *  TOKEN  THEN  RETURN  TRUE! 

end; 

RETURN  FALSE; 

END  no$con?lict; 

RECOVER :  PROC  BITE; 

DCL  TSP  BTTE,  RSTATE  ADDRESS; 

do  forever; 
tsp  *  sp; 

DO  WHILE  TSP  <>  255; 

IF  NO$CONFLICT( RSTATE  :=  STATESTA CK( TSP) )  THEN 
DO;  /*  STATE  WILL  READ  TOKEN  */ 

IF  SP  <>  TSP  THEN  SP  =  TSP  -  If 
RETURN  RSTATE; 

END; 

TSP  *  TSP  -  If 

end; 

CALL  SCANNER?  /*  TRT  ANOTHER  TOKEN  */ 

end; 

END  RECOVER; 

/**«*«  PROGRAM  EXECUTION  STARTS  HERE  *  *  */ 

/*  INITIALIZATION  */ 

TOKEN  »  80?  /*  PRIME  THE  SCANNER  WITH  -PROCEDURE-  */ 

CALL  MOV  E(  PAS  SI  $  TOP  -  PASS1$LEN  ,  .DEBUGGING  ,PASS1  $LEN  )  ,* 
LISTSEND  «  .LIST$BUFF  +  127; 

LIST$PTR  *  .LIST$BUFF  +  LIST$PTR; 

OUTPUT$END  »  ,OUTPUT$BUFF  +  127; 

OUTPUTSPTR  *  .OUTPUTSBUFF  +  OUTPUTSPTR? 

CALL  PRINT$ERROR (FALSE);  /*  INITIALIZE  ERROR  MSG  CUTPUT  V 
/«**«***  PARSER  ***#*♦/ 

DO  WHILE  compiling; 

IF  STATE  <-  MAXRNO  THEN  /*  READ  STATE  •/ 

do; 

CALL  INCSP; 

STATESTACK (SP )  »  STATE?  /*  SAVE  CURRENT  STATE  */ 

CALL  lookahead; 

I  -  gstini; 


J  «  I  ♦  GETIN2  -  li 
DO  I  »  I  TO  j; 

IE  HEADl(I)  =  TOKEN  TEEN 

do; 

IF  {TOKEN  =  INPUT$STR )  05 
(TOKEN  =  LITERAL)  THEN 
DO  K  =  0  TO  ACCUM(e); 

VARC (K  )  »  AC  CUM (E)J 

end; 

STATE  =  READ2(I)? 

nolook  =  true; 
i  =  j; 

end; 

ELSE  IF  I  =  J  THEN 

eo; 

CALL  PRINT$ERROR( 'NP')? 

CALL  PRI NT ( .  (  '  ERROR  NEAR  $'))? 

CALL  PRINT$ACCUMJ 
IF  (STATE  :*  RECOVER)  =  0  TIFN 
COMPILING  -  FALSE; 

END;  /*  END  OF  IF  I  =  J  */ 

END;  /*  END  OP  I  *  I  TO  J  */ 

END;  /*  END  OF  READ  STATE  */ 

ELSE  IF  STATE  >  MAXPNO  THEN  /*  APPLY  PRODUCTION  STATE  */ 

do; 

MP  «  SP  -  GETIN2; 

MPP1  *  MP  +  lj 

CALL  CODE$GEN (STATE  -  MAXPNO); 

SP  *  mp; 

I  =  GETINl; 

J  »  STATESTACK(SP); 

DO  WHILE  (K  :=  APPLYl(I))  <>  3  AND  J  <>  KJ 
I  »  I  ♦  i; 

end; 

IF  (K  :  =  APPLT2( I ) )  =  0  THEN  COMPILING  =  FALSE; 
STATE  =  K; 

end; 

ELSE  IF  STATE  <*  MAXLNO  THEN  /^LOOKAHEAD  STATE*/ 

do; 

I  *  GETIN1J 
CALL  lookahead; 

DO  WHILE  (X  :«  LOOKl(I))  <>  0  AND  TOKEN  <>  K; 
i  -  i  ♦  i; 

end; 

STATE  «  L00K2(I); 

end; 

ELSE  DO?  /*PUSH  STATES*/ 

CALL  INCSP; 

STATESTACK(SP)  -  GETIN2J 
STATE  ■  GETINl? 


end; 


END?  /*  OF  WHILE  COMPILING  */ 


CALL  CODE$BTTE(TER)» 

CALL  ADDR$OUT(MAX$INT$MEM)» 

IF  NOT  NO$CODE  THEN 

do; 

CALL  VRITE$OUTPUT( .OUTPUT$BUFFf .OUTPUT$FCB) ; 
CALL  CLOSE(.OOTPUT$FCB); 

end; 

call  chece$unresolted; 
call  crlf; 
call  dcrlf; 

DO  I  «  0  TO  4» 

CALL  PRINT$CHAR(ERROR$CTR(I)); 

CALL  WRITE$TO$DISK(SRROR$CTR( I)) ; 

end; 

CALL  PRINT( •('  PROGRAM  ERROR{ S )$'))? 

DO  WHILE  LIST$PTR  <  LIST$ENDJ 
CALL  WRITE$T0$DISK ( *  ')} 

end; 

CALL  WRITE$TO$DISK(  '  ')? 

CALL  CLOSE ( .LIST$FCB); 

CALL  boot; 
end; 


COMPUTER  LISTING  FOR  HOPPLE  CINTERP  NPS  MICRO-COBOL 


$  TITLE('NPS  MIRCO-COBOL  COMPILER  INTERP')  PAGEWI DTP (80 ) 
PAGELENGTH(60) 

INTERP:  DO? 


/*  COBOL  COMPILER-INTERPRETER  */ 

/*  NORMALLY  LOCATED  AT  103H  */ 

/*  GLOBAL  DECLARATIONS  AND  LITERALS  */ 


DCL 


DCL 

LITERALLY 

'DECLARE', 

LIT 

LITERALLY 

'LITERALLY' 

CR 

LIT 

'13'. 

FALSE 

LIT 

'a'. 

FOREVER 

LIT 

'WHILE  TRUE 

LF 

LIT 

'10'. 

PROC 

LIT 

'PROCEDURE' 

SER 

LIT 

'12',  /* 

TAB 

LIT 

'09H', 

TRUE 

LIT 

'1', 

ZONE 

LIT 

'80i'; 

/*  UTILITY  VARIABLES  */ 


DCL 


A$CTR 

ADDRESS, 

BASE 

ADDRESS, 

ROOTER 

ADDPESS 

INITIAL  ( 0000H 

B5ADDR 

BASED  BASE 

(1) 

ADDRESS, 

B$BYTE 

BASED  BASE 

(1) 

BYTE, 

call$base 

ADDRESS , 

CALL$PTR 

BASED  CALL$BASE  (1) 

ADDRESS, 

CALL$TOP 

ADDRESS, 

CTR 

BYTE, 

CTR1 

BYTE, 

ERR0R$CTR(5) 

BYTE 

INITIAL  ('  l 

HOLD 

ADDRESS, 

H$ADDR 

BASED  FOLD 

(1) 

ADDRESS, 

H$BYTE 

BASED  HOLD 

(1) 

BYTE, 

HI$FREE$M.EM 

ADDRESS , 

LOW$FREE$MEM 

ADDRESS, 

EI$OF?SET 

ADDRESS 

INITIAL  ( 0' , 

LOW$ OFFSET 

ADDRESS 

INITIAL  (0) , 

INDEX 

BYTE, 

RTN$BASE 

ADDRESS, 

RTN$PTR 

BASED  RTN$BASE  (1) 

ADDRESS , 

/*  CODE  POINTERS  V 


s 
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CODE$START  ADDRESS  INITIAL(3500H ) , 

PPOGRAM$COUNTER  ADDRESS, 

C$ADDR  BASED  PROGRAM$COUNTER ( 1 )  ADDRESS, 

C$BYTE  BASED  PROGRAM$COUNTER ( 1 )  BITE, 

MAX$MEMORY  ADDRESS  IN  I TI  AL(  0B100H ) » 

/****♦  GLOBAL  INPUT  AND  OUTPUT  ROUTINES  **##*/ 

DCL 

CUPRENT$FCB  ADDRESS, 

STARTSOFFSET  LIT  '37'; 

MON1:  PROC  (F,A)  EXTERNAL} 

DCL  F  BYTE,  A  ADDRESS} 

END  MON1 } 

MON?:  PROC  (F,A)  BITE  EXTERNAL} 

DCL  F  BYTE,  A  ADDRESS} 

END  MON 2} 

PRINTSCHAR :  PROC  (CHAR)} 

DCL  CHAR  BYTE} 

CALL  MON  1  (2, CHAR); 

END  print$char; 

CRLF:  PROC} 

CALL  PRINTSCHAR(CR); 

CALL  PRINT$CHAR(LF) } 

END  CRLF} 

PRINT:  PROC  (A)} 

DCL  A  ADDRESS} 

CALL  CRLF} 

CALL  MON1 (9,A) } 

END  PRINT} 

READ:  PROC (A)} 

DCL  A  ADDRESS} 

CALL  MON1 (10 ,A) } 

END  READ} 

PRINT$ERROR:  PROC  (CODE)} 

DCL  CODE  ADDRESS,  I  BYTE,  TEN  LIT  '39E'} 

CALL  CRLF} 

CALL  PR I NTSC  EAR (HIGH (CODE) ) } 

CALL  PR I NTSC BAR (LOV( CODE } ) } 

I  «  4} 

DO  WHILE  (ERRORSCTR(I)  :«  ERRORSCTR ( I )  ♦  1)  =  TEN} 
ERRORSCTR(I)  *  '0'} 

IF  I  >  0  THEN 
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IT  ERROP$CTR ( I  :  =  I  -  1)  =  '  '  THEN 
ERROR$CTR(I)  =  '0"; 

end; 

end  print$error; 

FATAL$ERROR:  PROC(CODE); 

DCL  CODE  address; 

CALL  PRINT$ERROR(CODE)J 

CALL  MON1 (9, . ( '  FATAL  ERROR  $ '  ) ) ; 

call  booter; 

END  fatal$error; 

SET$DMA:  PROC; 

CALL  MON1  (26,  CURRENT$FCB  +  START$OFFSET ) ? 

END  set$dma; 

OPEN:  PROC  (ADDR)  BYTE; 

DCL  ADDR  ADDRESS,  RET  BYTE; 

CALL  MON1  (26, 60S); 

RET  =  I-0N2(15,ADDR); 

CALL  SET$DMA;  /*  RESET  BUFFER  */ 

RETURN  RET; 

end  open; 

CLOSE:  PROC  (ADDR)*, 

DCL  ADDR  ADDRESS; 

CALL  MON1  (26.80H); 

IF  M0N2(16,ADDR)  *  255  THEN  CALL  FATAL^ERROB ( 'CL' ) ; 
CALL  SET$DMA;  /*  RESET  BUFFER  */ 

END  close; 

DELETE:  PROC J 

CALL  M0N1(19,CURRENT$FCB); 

END  delete; 

MAKE:  PROC  (ADDR); 

DCL  ADDR  ADDRESS; 

IF  M0N2 (22 , ADDR )  =  255  THEN  CALL  FATAL$ERROR( 'ME ' ) ; 
END  MAKF. 

DISK$READ:  PROC  BYTE; 

RETURN  MON2(20,CURRENT$FCB); 

END  DISK$READ>* 

DISK$WRITE:  PROC  BYTE; 

RETURN  M0N2(21,CURRENT$FCB); 

end  disk$write; 

/»**«*«****  UTILITY  PROCEDURES  ******** 


DCL 
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*  */ 


SUBSCRIPT 


(8) 


address; 


RES:  PROC(ADDR)  ADDRESS? 

/*  THIS  PROC  RESOLVES  THE  ADDRESS  OE  A  SUBSCRIPTED 
IDENTIFIER  OR  A  LITERAL  CONSTANT  */ 

DCL  ADDR  ADDRESS, 

I  BITE? 

IF  ADDR  >  32  THEN 

IF  ADDR  >  HI$FREE$MEM  THEN  RETURN  ADDR  -  HI $OFFSET 
ELSE  RETURN  ADDR  +  LOViOFFSST? 

IF  ADDR  <  8  THEN  RETURN  SUBS CRIPT (ADDR )  ? 

IF  ADDR  >  12  TEEN  RETURN  CALL$PTR  (ADDR  -  12)? 

DO  CASE  ADDR  -  10? 

RETURN  .('  ')? 

RETURN  .(27H)? 

RETURN  .  (  '0  '  )  J 

END? 

RETURN  a; 

END  res; 

MOVE:  PROC (FROM .DESTINATION .COUNT)? 

DCL  (FROM, DESTINATION. COUNT)  ADDRESS, 

(F  BASED  FROM,  D  BASED  DESTINATION)  BYTE? 

DO  WHILE  (COUNT  :  =  COUNT  -1)0  0FFFFE? 

D  *  F? 

FROM  *  FROM  +  1? 

DESTINATION  *  DESTINATION  +  1? 

END,* 

END  MOVE? 

FILL:  PROC (DESTINATION, COUNT, CHAR)? 

DCL  (DESTINATION, COUNT)  ADDRESS, 

(CHAR.D  BASED  DESTINATION)  BYTE? 

DO  WHILE  (COUNT  :=  COUNT  -1)0  0FFFFH? 

D  ■  char; 

DESTINATION  =  DESTINATION  +  1? 

END? 

END  fill; 

FILLER:  PROC  BYTE? 

IF  C$ADDR(1)  *  0BH  THEN  RETURN  27H? 

ELSE  IF  C$ADDR (1 )  =  0CR  THFN  RETURN  '0'? 

ELSE  RETURN  ' 

END  filler; 

CONVERT$TO$HEX:  PROC ( POINTER .COUNT )  ADDRESS; 

DCL  POINTER  ADDRESS,  (COUNT .CHAR  ,CTR)  BYTE? 

A$CTR  =  0? 

BASE  =  POINTER? 

DO  CTR  *  0  TO  COUNT  -  1? 

IF  ((CHAR  :=  B$BYTE( CTR) )  *  '-')  OR 
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((CHAR  -  ZONE  >=  '0')  AND 
(CHAR  -  ZONE  <=  '9'))  THEN  RETURN  A$CTR  :=  0t 
IP  CHAR  =  THEN  RETURN  A$CTR» 

IP  CHAR  <>  THEN 

A$CTR  =  SHL ( A$CTR, 3)  +  SHL(A$CTR.l)  * 

(CHAP  -  '0')i 

end; 

RETURN  A$CTR; 

END  C0N7ERT$T0$HEX» 

/***«*#**«  code  CONTROL  PROCEDURES  ##»*##***/ 


DC!  BRANCH$FLAG  ETTE  INITIAL(PALSE) • 

INC$PTR :  PROC  (COUNT); 

DC!  COUNT  BYTE; 

PROGRAM  COUNTER  *  PROGRAMS COUNTER  +  COUNT; 

END  INC$PTRJ 

GET$OP$CODE :  PROC  BYTE; 

CTR  =  C$BYTE(0); 

CALI  INC$PTR(1); 

RETURN  CTR; 

end  get$op$code; 

COND$BRANCH:  PROC(COUNT); 

/*  THIS  PROC  CONTROLS  BRANCHING  INSTRUCTIONS  */ 

DCL  COUNT  BYTE! 

IP  BRANCH$PLAG  THEN 

do; 

BRANCHSFLAG  =  FALSE; 

PROGRAMSCOUNTER  =  C$ADDR (COUNT  ) ; 

end; 

ELSE  CALL  INCSPTR ( SHL ( COUNT , 1 )  +  2); 

END  CONDiBRANCH; 

INCR$OR$BRANCH:  PROC (MARK ) ; 

DCL  MARK  BYTE; 

IF  MARK  THEN  CALL  INC$PTR(2); 

ELSE  PROGRAM$COCNTER  *  C$ADDR(0); 

END  incr$or$branch; 

/*»***«»****«  COMPARISONS  ************/ 


CHAR$COMPARE :  PROC  BYTE; 

DCL  A $ AD DR  ADDRESS; 

A$ADDR  *  FILLER? 

IF  C$ADDR(1 )  >  09H  AND  C$ADDR(1)  <  0DH  THEN 
DO  A$CTR  «  0  TO  C$ADDR(2)  -  If 

IF  B$BYTE( AiCTR)  >  ASADDR  THEN  RETURN  1? 
IF  B$BYTE(A$CTR)  <  A$ADDR  THEN  RETURN  0; 
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ELSE 

DO  A$CTR  =  0  TO  C$ADDR(2)  -  i; 

17  B$BYTE(A$CTR)  >  HSBYTE ( A $CTR )  THEN  RETURN  1 
17  B$BYTE(A$CTR)  <  H*BYTE(A$CTR )  THEN  RETURN  0 

end; 

RETURN  2; 

END  CHAR$COMPARE» 

NUMERIC:  PROC (CHAR )  BYTE; 

DCt  CHAR  BYTE? 

RETURN  (CHAR  >=  '0')  AND  (CHAR  <=  '9'); 

END  numeric; 

LETTER:  PROC (CHAR)  BYTE? 

DCL  CHAR  BYTF. 

RETURN  (CHAR  >=  'A')  AND  (CHAR  <=  'l'); 

end  letter; 

SIGN:  PROC (CHAR)  BYTE? 

DCL  CHAR  BYTE? 

RETURN  (CHAR  =  '+')  OR  (CHAR  =  '-'); 

END  SIGN; 

CHK$S$NUM:  PROC(BASE)  BYTE; 

DCL  BASE  ADDRESS, 

B$BYTE  BASED  BASE  (l)  BYTE, 

( I ,LENGTE )  BYTE; 

DO  I  *  1  TO  (LFNGTH  :=  C$ADDR(2)  -  1)  -  i; 

IE  NOT  NUMERIC(B$BYTE( I ) )  T*EN  RETURN  FALSE; 

end; 

IF  NUMERIC (B$BYTE(0) )  AND  NUMERIC (B$BYTE( LENGTH) )  THEN 
RETURN  FALSE; 

CALL  MOVE(BASE,.R0, LENGTH  +1); 

IF  NUMERIC (B$BYTE(0 )  -  ZONE)  AND 
NUMERIC (B$RYTF(LENGTH) )  THEN 
R0(0)  =  R0(0)  -  zone; 

ELSE  IF  NUMERIC (B$BYTE(0) )  AND 

NUMERIC (B$BYTE(LENGTH)  -  ZONE)  THEN 
R0(LENGTH)  *  R0(LENGTH)  -  ZONE? 

ELSE  RETURN  FALSE* 

RETURN  TRUE* 

END  cek$s$num; 

STRING$COMPARE:  PROC(PIVOT); 

DCL  PIVOT  byte; 

HOLD  -  RES (C$ADDR ( 1 ) ) ; 

IE  CHE$S$NUM (BASE  :=  RES (C$ADDR( 0 ) ) )  THEN  BASE  =  .R0; 
ELSE  IF  CHE$S$NUM(HOLD)  THEN  HOLD  =  .R0J 
IF  CBAR$COMPARE  =  PIVOT  TEEN 

BRANCH$FLAG  *  NOT  BRANCH$FLAGJ 


CALL  C0ND$BRANCH(3)T 

end  string$compare; 

COMP$NUM$CNSIGNED:  PROCT 
BASE  =  RES(C*ADDR(0)); 

DO  A$CTR  *  0  TO  C$AEDR(1)  -  IT 

IP  NOT  NUMFRI C( 3$BYTE( A$CTP ) )  THEN 
A$CTR  =  CUDDR(l)  +  IT 

ENDT 

IP  A$CTR  =  C $ADDR (1 )  TEEN  BRANCH$FLAG  =  NOT  BRANCH$FLAG T 
CALL  C0ND$BRANCH(2)T 

END  comp$num$unsigned; 

COMP$NUM$S IGN  :  PR0CT 

DCL  (CHAR  ,$IGN$FLAG)  BYTPi 
SIGN$FLAC-  =  FALSE; 

BASE  -  FES ( C$ADDR (0 ) ) » 

DO  A$CTR  =  0  TO  CiADDR(l)  -  1» 

IF  NOT  NUMERIC(CHAR  :=  B$BYTE ( A$CTR ) )  TEEN 

IP  (A$CTR  =  0)  OR  ( 4$CTR  =  C$ADDP.(1)  -  1)  THEN 
IF  (SIGN(CHAR)  OR  NUMERIC (CHAR-ZONE ) )  AND 
NOT  SIGN$FLAG  THEN 
S IGN  $PLAG  =  TRUE? 

ELSE  A4CTR  =  C$ADDR(1)  +  1J 
ELSE  A$CTR  =  C$ALDR(1)  +  IT 

end; 

IF  A$CTR  =  CSADDP(l)  THEN  BRANCH$FLAG  =  NOT  BPANCHSFLAG? 
CALL  C0ND$BRANCH(2); 

FND  comp$ndm$sign; 

COMPSALPHA:  proc; 

BASE  =  RES (C$ADDR (0) ) T 
DO  ASCTR  =  0  TO  C$ADDR(1)  -  IT 

IF  NOT  LFTTER(B$BYTE(A$CTR ) )  THEN 
A$CTR  «  C$ADDR( 1 )  +  IT 

END; 

IF  A5CTR  =  CiADDR(l)  THEN  BRANCHSFLAG  =  NOT  BPAN CH^PLAG? 
CALL  C0ND$BRANCE(2); 

END  COMP$ALPHAT 

/*««******#  ^NUMERIC  OPERATIONS  **********/ 


(R0 ,R1 ,R2 )  (18) 
DEC$PT0  BYTE, 
DECiPTl  BYTE, 
DEC$PT2  BYTE, 
DEC$PTA (? )  BYTE 
M07E$FLAG  BYTE 
OVERFLOW  BYTE, 
R$PTR  BYTE, 

REG$LENGTH  BYTE 


BYTE,  /*  REGISTERS  */ 


AT(  .DFC$PT0), 
INITIAL(FALSE) , 


I NI TIAL ( 10 ) , 
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S IGN0 (3 ) 

BYTE, 

SWITCH 

BYTE, 

TEMP 

BYTE, 

NEGITIVE 

LIT 

POSITIVE 

LIT 

C HECK SFORS SIGN:  PROC(CHAR)  BYTE  * 

DCL  CHAR  BYTE; 

I*  NUMER IC( CHAR )  THEN  RETURN  POSITIVE; 

IF  NUMERIC  (CHAR  -  ZONE)  THEN  RETURN  NEC-ITIVE; 
CALL  PRINTS  ERROR ( 'SI'); 

RETURN  POSITIVE; 

end  check$forSsign; 

STORESIMMEDIATE:  PROC; 

DO  CTR  =  0  TO  9; 

R0 (CTR  )  «  R2(CTR)J 

end; 

DEC$PT0  =  DECSPT2; 

SIGN0(0)  =  SIGN0(2)J 
END  STORES  IMMEDIATE; 

ONESLFFT:  PROC; 

DCL  CTR  BYTE? 

IF  SHL(B$BYTE(0),4)  *  0  OR  MOVESFLAG  THEN 

do; 

DO  CTR  -  0  TO  REGSLENGTH  -  2J 

BSBYTE(CTR)  =  SHL( BSBYTE (CTR ) , 4)  OR 

SHR(3$BYTE(CTR  +  1),4)J 

end; 

B$BYTE( REGSLENGTH  -  1)  * 

SEL(B$BYTE(REGSLENSTH  -  1),4); 

end; 

ELSE  OVERFLOW  *  TRUE; 

END  oneSleft; 

onesrightj  proc; 

DCL  CTR  BYTE; 

CTR  »  REGSLENGTH; 

DO  INDEX  «  1  TO  REGSLENGTH  -  1? 

CTR  «  CTR  -  l; 

BSBYTE(CTR)  «  SHR ( B$BYTE( CTR ) ,4 )  OR 
shl(bsbyte(ctr  -  i),4); 

end; 

B$BYTE(0)  »  SHR(B$BYTE(0),4); 

IF  BSBYTE  (0)  *  09H  THEN 
BSBYTE(0)  «  99H; 

END  onesright; 

SHIFTSRIGHT:  PROC(COUNT); 

DCL  COUNT  BYTE; 
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ro  CTR  «  1  TO  COITNT* 

CALL  one$right; 

END? 

END  SSIFT$RIGET; 

SHIFT$LEFT:  PROC  (COUNT); 

DCL  COUNT  BITE? 

OVERFLOW  *  FALSE? 

IF  COUNT  *  0  THEN 
DO? 

CTR  «  0; 

RETURN ; 

end; 

DO  CTR  *  0  TO  COUNT  -  l; 

call  one$left; 

IF  OVERFLOW  AND  NOT  MOVE$FLAG  THEN  RETURN; 

end; 

END  SHIFT$LEFT; 

ALLIGN:  PROC; 

DCL  (X.Y)  byte; 

RIGHT$OP : PROC ( ADDR ) ; 

DCL  ADDR  ADDRESS! 

IF  OVERFLOW  THEN 

do; 

BASE  -  addr; 

CALL  SHIFT$RIGHT(Y  :=  X  -  CTR); 
OVERFLOW  =  FALSE; 

end; 

END  RIGHTSOP; 

Y  »  0; 

IF  DEC  $PT0>DEC $PT1  THEN 

do; 

BASE  *  .Ri; 

CALL  SHIFT$LEFT(X  :=  DFC$PT0  -  DEC$PT1) 
DEC$PT1  =  DEC$PT1+CTR; 

CALL  RIGHT$OP( .P0); 

DEC $PT0  *  DEC$PT2  -  YJ 

end; 

ELSE 

do; 

BASE  «  .R0; 

CALL  SHIFT$LEFT(X  :=  DEC$PT1  -  DEC$PT0) 
DEC$PT0  ■  DEC$PT0+CTR; 

CALL  RIGHT$OP(.Rl); 

DEC$PT1  «  DSC$PT1  -  Y; 

end; 
end  allign; 


ADD$TO$END:  PROC(CY)? 


dcl  (cy,i  ,J )  byte; 

CTR  =  REG$LENGTF  -  1? 

DO  J  *  1  TO  reg$length; 

I  -  B$BTTE(CTR); 

I  -  DECd+CY); 

CY  *  CARRY  AND  i; 

B$3YTE(CTR)  *  I? 

CTR  =  CTR  -  1? 

end; 

END  ADD$TO$END» 

ADD$R0:  PROC(SECOND,  DEST); 

DCL  (SECOND,  DEST)  ADDRESS,  (CY.A.B.I.J)  BYTE? 

HOLD  =  second; 

BASE  *  lest; 

CY  »  0; 

CTR  »  REG$LENGTH  -  1? 

DO  J  «  1  TO  reg$lenc-th; 

A  -  R0(CTR).‘ 

B  *  H$3YTE (CTR) ? 

I  *  DEC (A+CY ) » 

CY  =  carry; 

I  -  DEC (I  ♦  3); 

CY  *  (CY  OR  CARRY)  AND  i; 

BSBYTE(CTR)  »  IJ 
CTR  =  CTR  -  I? 

end; 

IE  CY  THEN  CALL  ADD$TO$END( CY) ? 

END  ADD5R0; 

COMPLIMENT:  PROC(NUMB); 

DCL  NUMB  BYTE; 

SIGN0( NUMB )  =  SIGN0 ( NUMB )  XOR  IS  /*  COMPLIMENT  SIGN  */ 
DO  CASE  numb; 

HOLD  *  ,R0; 

HOLD  »  .Ri; 

HOLD  =  .R2; 

end; 

DO  CTR  ■  0  TO  REGiLENGTH  -  i; 

H$BYTE ( CTR)  *  99H  -  H$BYTE(CTR); 

end; 

END  COMPLIMENT; 

R2$ZER0:  PROC  BYTE? 

DCL  I  byte; 

IE  ( SHI (R2 (0 ) ,4 )  <>  0)  OR  ( SFR (R2 ( 9) ,4)  <>  0) 

THEN  RETURN  FALSE; 

ELSE  DO  I  *  1  TO  e; 

IE  R2(I)  <>  0  THEN  RETURN  FALSE? 

end; 

RETURN  TRUE? 


END  R2$ZE?0? 

LEADI NG$ZEROES :  PROC (ADDR)  BYTE? 

DCL  COUNT  BYTE,  ADDR  ADDRESS; 

COUNT  =  0; 

BASE  =  ADDR? 

DO  CTR  ■  0  TO  9? 

IF  (?$BYTE(CTR )  AND  0F0H)  <>  0  THEN  RETURN  COUNT? 
COUNT  =  COUNT  +  1? 

IF  (B$BYTE(  CTR )  AND  0FH )  <>  0  THEN  RETURN  COUNT,* 
COUNT  *  COUNT  +  1? 

END? 

RETURN  COUNT? 

END  LEADI NG$ZEROES? 

CEECX$RESULT :  PROC? 

IF  SER(R2(0) ,4)  -  9  THEN  CALL  COMPLIMEN T( 2 ) ? 

BASE  =  .R2? 

CALL  ADD$TO$END (05E ) ? 

IF  (SER(R?(0> ,4 )<>0 )  AND  (DEC$PT2  =  0)  THEN 
OVERFLOW  =  TRUE? 

else 

IF  ( SER ( R2(0 ) ,4)  <>  0)  THEN 
DO? 

CALL  SHIFTSRIGHT(I)? 

DEC$PT2  «  DFC$PT2  -  1? 

END? 

B$PYTE (9 )  «  B$BYTE(9)  AND  0F01? 

IF  LEADING$ZEROES( .R2)  >  19  TEEN 
SIGN0(2)  »  POSITIVE? 

END  CHECK$RESULT? 

CEECE$SIGN ;  PROC? 

SIGN0(2)  =  POSITIVE? 

IF  SIGN0(0)  AND  SIGN0(1)  THEN  RETURN? 

IF  (NOT  SIGN0(0) )  AND  (NOT  SIGN0(1))  THEN 
DO? 

S IGN0 (2 )  *  NEGITIVE? 

RETURN  ? 

END? 

IF  SIGN0(0)  THEN  CALL  COMPLIMENT (1 )  ? 

ELSE  CALL  COMPLIMENT(0 ) ? 

END  CHECK$SIGN? 

CEECK$NUMERIC :  PROC? 

DCL  I  BYTE? 

BASE  »  .R0? 

DO  I  -  0  TO  27? 

IF  NOT  NUM.EP IC(SHR(B$BYTE(I),4)  OR  '0')  OR 

NOT  NUMERIC ( (B$BYTE ( I )  AND  0FH)  OR  '0')  TPEN 
CALL  PRINT$ERROR(  'NE')? 
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end; 

END  CEFCKSNUPERIC; 

CHFCESDEC IML :  PROCJ 

IF  DSC$PT2<>( CTR  :=  C$BYTE(3))  THEN 

do; 

MOVE$FLAG  =  TRUE; 

BASE  =  .R2; 

IF  DECSPT2  >  CTR  THEN  CALL 

SHIFT$RIGHT(DFC$PT2  -  CTR); 

ELSE  CALL  SHIFT$LEFT(CTR-DEC$PT2 ) ; 

MOVESFLAG  =  FALSE; 

end; 

IF  LEADINC-$ZFR0ES(.R2)  <  19  -  C$BTTE(2)  THEN 
OVERFLOW  *  TRUE? 

END  CHECKSBECIMAIJ 

ADD:  PROC; 

CALL  CHFCK$NUMERIC; 

OVERFLOW  »  FALSE? 

call  allign; 

CALL  CHECKS SIGN; 

DECSPT2  -  DEC$PT0J 
CALL  ADDR0( .R1..R2); 

CALL  CHECKSRESULTJ 

end  add; 

ADDSSERIES;  PROC (COUNT); 

DCL  (I, COUNT)  BYTE; 

DO  I  *  1  TO  count; 

CALL  ADD$R0( .R2, .R2); 

end; 

END  ADDSSFRIFS; 

SET$*ULT$DIV:  PROC? 

CALL  CHFCKSNUrEPIC; 

OVERFLOW  *  FALSE; 

REGSLENGTH  -  16? 

SIGN0(2)  -  (NOT  (SIGN0(0)  FOR  SIGN0(1)))  AND  PIE; 

CALL  FILL(.R2,ie,0); 

END  SETSMU LTSDIV; 

RlSGRFATFP:  PROC  BYTE; 

DCL  I  byte; 

DO  CTR  *  0  TO  9? 

IF  R1(CTR)>( I  99H  -  R0(CTR))  THEN  RETURN  TRUE; 

if  rkctrXi  then  return  false; 
end; 

return  true; 

END  RlSGREATFR; 
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MULTIPLY:  PROC( VALUE); 

DCL  VALUE  BYTE? 

IP  VALUEO0  THEN  CALL  ADD$SERIES (VALUE ) ; 
BASE  *  .R0J 
CALL  ONE$LEF?J 
END  multiply; 

divide:  proc; 

DCL  (I,  J.  K ,  x)  byte; 

IP  LEADING$ZEROES( .R0)  >  19  THEN 

do; 

OVERFLOW  =  TRUE; 

RETURN ; 

end; 

IP  LEADING$ZEROES( .Rl)  >  19  TEEN 

do; 

CALL  FILL(.R2,ie,0); 

RETURN ; 

end; 

CALL  SET$MULT$DIVJ 
BASE  “  .R0; 

CALL  SEIPT$LEPT(17); 

DEC$PT0  *  DEC$PT0  +  CTRJ 
BASE  =  .Ri; 

CALL  SHIFTS  LEFT (17) ; 

DEC$PT1  ■  DECSPT1  +  CTR; 

OVERPLOV  »  TALSTJ 
IP  DECSPT0  >  17  THEN 

IP  DECSPT1  <  (X  :=  DEC$PT0  -  1?)  THEN 

do; 

OVERFLOW  =  TRUE; 

DECSPT2  *  0! 

end; 

ELSE 

DSC$PT2  =  DEC$PT1  -  X? 

ELSE 

DECSPT2  »  DECSPT1  +  (17  -  DECSPT0); 
CALL  COMPLIMENT^)? 

DO  I  *  1  TO  19? 

j  «  0; 

DO  WHILE  risgreater; 

CALL  ADD$R0(.R1,.R1); 

IF  Rl (0 )  =  99H  THEN 

CALL  COMPLIMENT  (1); 
j  »  j  ♦  i; 

end; 

x  «  SHR(I.l)? 

IF  I  THEN  R2(E)  «  R2(K)  OR  J; 

ELSE  R2(K)  -  R2( K )  OR  SHL(J,4)J 
BASE  *  .R0; 

CALL  ONE$RIGHTJ 


end; 

REG$LENGTH  =  10? 

CALL  check$result; 

END  DIVIDE? 

LOAD$A$CEAR:  PROC(CHAR)? 

DCL  CHAR  BYTE? 

IP  (SWITCH  :  =  NOT  SWITCH)  THFN 

B$BTTE (R$PTR )  =  B$BTTE ( R$PTR )  OR  SBL ( CHAR 
ELSE  B$3YTE(R$PTR  :  =  R$PTR-1)  =  CHAR  -  30E? 

END  LOAD$A$CHAR? 

LOAD$NUMBERS:  PROC (ADDR, CNT> ? 

DCL  ADDR  ADDRESS,  (I.CNT)BYTE? 

HOLD  =  RES (ADDR)? 

CTR  *  CNT? 

DO  INDEX  -  1  TO  CNT? 

CTR  =  CTR  -  1? 

CALL  LOAD$A$ CHAR (H$ BYTE (CTR  ) )  ? 

END? 

CALL  INC$PTR(5)? 

END  LOADSNUMBERS? 

SET$LOAD:  PROC  (SIGN$IN)? 

DCL  (CTR  ,SIGN$IN  )  BYTE? 

DO  CASE  (CTR  :*  C$BYTE(4))? 

BASE  »  .R0? 

BASE  *  .HI ; 

BASE  »  .R2? 

END? 

DEC$PTA (CTR )  »  C$BYTE(3)J 
SIGN0(CTR)  «  SIGN$IN? 

CALL  PILL  (BASE, 18.0)? 

R$PTR  »  g; 

SWITCH  »  PALSE? 

END  SET$LOAD? 

LOAD$NUMERIC :  PROC? 

CALL  SET$LOAD(l); 

CALL  LOAD$ND«BERS (RES ( C  $  ADDR ( 0 ) ) ,C$BYTE(?  ) ) ; 
END  LOAD$NUMERIC? 

LOAD$NDMSLIT:  PROC? 

DCL( LIT$S IZE ,PLAG)  BYTE? 

CHARTS IGN :  PROC  > 

LIT$S IZE  -  LITSSIZE  -  1? 

HOLD  ■  HOLD  +  1? 

END  CHAR$SIGN? 

LIT$SIZE  -  CSBITE(2) ? 
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HOLD  =  RES( C$ADDR(0) ) J 
I?  H$BYTE (0 )  *  THEN 

do; 

call  char$sign; 

CALL  SET$LOAD(NEGITIVE>; 

end; 

ELSE 

do; 

IF  H$BYTE(0)  ■  THEN  CALL  CHAR$SIGN; 

CALL  SET$LOAD( POSITIVE  ) ; 

end; 

FLAG  =  0; 

CTR  *  lit$size; 

DO  INDEX  =  1  TO  LITiSIZEJ 
CTR  *  CTR  -  l; 

IF  H$BYTE(CTR)  *  THEN  FLAG=LIT$S I ZE  -  (CTR  +  l); 
ELSE  CALL  LOAD$A $CEAR ( H$?YTE (CTR )  )  * 

end; 

DFC$PTA(C$BYTE(4))  =  FLAG; 

CALL  I NC$PTR (5) » 

END  load$num$lit; 

STORE$ONE:  PROC; 

IF(SWITCH  :«  NOT  SWITCH)  THEN 

B$BYTE{ 0 )  »  SHH(H$BYTE(0)  ,4)  OR  '0'; 

ELSF 

do; 

HOLD  «  HOLD  -  1? 

B$BYTS(0)  -  (H$BYTE(0 )  AND  0FH)  OR  '0'; 

end; 

BASE  =  BASE  -  If 

end  store$one; 

STORE4AS$CHARj  PROC (COUNT); 

DCL  COUNT  BYTE; 

SWITCH  »  false; 

HOLD  *  .R2  +  9; 

IF  C4BYTE (4 )  <>  SER  OR  NOT  OVERFLOW  THEN 
DO  CTR  »  1  TO  COUNT; 

CALL  store$one; 

end; 

end  store$as$char; 

SET$ZONE:  PROC  (ADDR)f 
DCL  ADDR  ADDRESS! 

I?  NOT  SIGN0(2)  THEN 

do; 

BASE  «  addr; 

IF  C$BYTE(4)  <>  SER  OR  NOT  OVERFLOW  THEN 
B$BYTE<0)  »  BSBYTEO )  +  ZONE; 

end; 
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CALI  I NC$PTR (4 ) » 

END  SET$ZONE? 

SET$SIGN$SEP :  PROC  (ADDR) ? 

DCL  ADDP  ADDRESS; 

BASE  E  ADDR  J 

IE  C$BYTE (4 )  <>  SER  OR  NOT  OVERFLOW  THEN 
I?  SIGN0(2)  THEN  B$BYTE( 0 )  =  '«•'? 
ELSE  B£3YTE(0)  = 

CALL  INC$PTR(4); 

END  SET$SIGN$SEP? 

ST0RE$NUMERIC s  PROC? 

CALL  checksdfcimal; 

BASE  *  RES(C$ADDR (0 ) )  ♦  C$BYTE(2)  -  It 
CALL  STORE$AS$CHAR(C$BYTE(2) ) J 
END  STORE$NUMERIC; 

MCVE$NUM$EDITFD:  PROC. 


CHAR 

BYTE, 

COUNT 

BYTE, 

FLAG (2) 

BYTE, 

FLOAT$VALUE 

BYTE, 

LAST$LOAD 

BYTE, 

LENGTH 

BYTE, 

MAX$LOAD$PT 

BYTE, 

MIN$LOAD$PT 

BYTE, 

PS IT$DFC 

BYTE, 

PS IT$SIGN 

BYTE. 

SIGN$OUT 

byte; 

FLOAT$CHECX:  PROC(INDEX); 

DCL  INDEX  BYTE; 

IF  FLAG (INDEX)  THEN 

FLOAT$VALUE  *  CHAR? 

ELSE 

do; 

FLAG(INDEX)  *  TRUE; 

IF  CTR  <>  MAX$LOAD$PT  OR  INDEX  = 
MIN  $LOAI  $PT  =  CTR  +1? 

IF  INDEX  -  1  THEN 
PSIT$SIGN  ■  ctr; 

end; 

END  FLOATSCHECK? 

FLOAT$VALUE ,MIN$L0AD$PT  *  0; 

FLAG(0) ,FLAG(1 )  «  FALSE? 

PSITiDEC  -  C$BYTE(11); 

PSIT$SIGN  «  C$BYTE(8)J 
MAX$LOAD$PT  «  C$BYTS(8 )  -  1? 

HOLD  »  RES(C$ADDR(0)) ? 


0  THEN 
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CALL  MOVE (PS S (C$ADDR(3) ) .HOLD ,C$ADDR (4  ) )» 

IS  H$BYTE (MAX$LOAD$PT )  -  'B'  OR 
H$BYTE(MAX$LOAD$PT)  =  'R'  THEN 

do; 

MAX$LOAD$PT  *  MAX$LOAE$PT  -  2? 

PSIT$DSC  *  PS IT$DEC  -  2? 

PSIT$SIGN  *  PSIT$SIGN  -  2J 

end; 

DO  CTR  *  0  TO  MAX$LOAD?PT; 

CHAR  =  H$BTTE(CTR)» 

IF  CHAR  =  '9'  THEN 

H$BTTE(CTR)  »  'O'! 

ELSE  IT  CHAR  =  '$'  THEN 
CALL  FLOAT$CHECK(0); 

ELSE  IF  SIGN (CHAR)  THEN 
CALL  TL0AT$CHECK(1 ) » 

ELSE  IF  CHAR  =  'Z '  THEN 
FLOAT? VALUE  *  CHAR? 

ELSE  IF  CHAR  «  'B'  THEN 
E$BTTE(CTR)  =  '  'i 

IF  CTR  >  MAX$LOAD$PT  -  PSIT$DFC  THEN 
IF  CHAR  «  '/'  OR  CHAR  =  '  '  OR 
CHAR  =  '0'  OR  CHAR  =  '  THEN 

PSIT$DEC  *  PSIT$DEC  -  1? 

END?  /*  DO  CTR  *  0  TO  MAX$LOAD$PT  */ 

IF  PS IT$S IGN  =  MAX$LOAD$PT  THEN 

do; 

MAX?LOAD$PT  »  MAX$LOAD?PT  -  i; 

PSIT$DEC  *  PSIT$DEC  -  1?  * 

end; 

LENGTH  =  C$ADDR(2); 

BASE  *  .R0J 

CALL  FILL(BASE,36. '0')! 

CALL  MOVE(RES(C$ADDR(l)) .BASE, LENGTH); 

IF  SIGN (B$BTTE(0 ) )  THEN  /*  CHECK  FOR  LEADING  SIGN  */ 

do; 

S IGN $OUT  »  B$BYTE(0); 

BASE  «  BASE  +  1? 

LENGTH  =  LENGTH  -  i; 

end; 

ELSE  IF  S IGN (B$BYTE(C$BYTE(4)  -  1))  THEN 

do; 

SIGN$OUT  *  B$BYTE(C$BYTE(4)  -  1)5 
LENGTH  =  LENGTH  -  l; 

end; 

ELSE  IF  NOT  C HECK $FOR$S IGN (B$BYTE(C$BYTE(4)  -  1))  THEN 
DO;  /*  CHECK  FOR  TRAILING  IMBEDDED  SIGN  */ 

S  IGN$OUT  « 

B$BYTE(C$BYTE( 4)  -  1)  -  B$BYTE ( CSBYTE (4 )  -  1) 

-  zone; 

end; 
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ELSE  IF  NOT  CHECK$FOR$SIGN ( B$BYTE(0  ) )  THEN 

DO?  /*  CHECK  FOR  LEADING  IMBEDDED  SIGN  */ 

S IGN  $OUT  ■ 

B$BYTE(0)  *  B$BYTE ( 0)  -  ZONE; 

end; 

ELSE  S  IGN$OUT  =  '  + 

IF  PSIT^DEC  <>  C $BYTE ( 10  )  THEN 

DO?  /*  ALIGN  DECIMAL  POSITIONS  */ 

IF  PSIT$DEC  <  C $3YTE( 10)  TEEN 

LENGTH  =  LENGTH  -  (C$BTTE(10)  -  PSIT$DEC); 

ELSE 

LENGTH  =  LENGTH  +  (PSITSDEC  -  C$BYTE(10)); 

end; 

CTR  =  LENGTH  ~  1J 

COUNT ,  LAS  T$  LOAD  =  MAX$LOAD$PT,* 

DO  INDEX  =  1  TO  LENGTH; 

DO  WHILE  (H$EYTE( COUNT)  =  '  '  OR  H*BYTE(COUNT)  =  '0' 
OR  H$BYTE(COUNT)  =  '/'  OR  H$BYTE( COUNT )  * 

OR  H$PYTE( COUNT)  =  AND 

(COUNT  <=  MAX$LOAD$PT)5 
COUNT  «  COUNT  -  1J 

end; 

IF  B$BYTE{CTR)  <>  THEN 
DO» 

IF  B$BYTE(CTR)  <>  '0'  THEN 

IF  (COUNT  <  MIN$L0AD$PT)  OR 
(COUNT  =  255)  THEN 

index  =  length; 

ELSE 

do; 

H$BYTE (COUNT )  =  B$BYTE(CTR) ; 
LAST$LOAD  *  COUNT,* 

end; 

COUNT  ■  COUNT  -  1? 

end; 

ctr  =  CTR  -  i; 

end; 

IF  FLOATSVALUE  <>  0  THEN 

do; 

ctr  =0; 

DO  WHILE  H$BYTE(CTR)  <>  FLOAT$VALUE; 

CTR  =  CTR  +  i; 

end; 

DO  WHILE  (H$BYTE( CTR )  =  OR  B$BYTE(CTB)  =  '0' 
OR  H$BYTE(CTR)  =  '  '  OR  H$BYTF(CTR)  *  '/' 
OR  H$PYTE(CTR )  =  FLOAT$VALUE) 

AND  (CTR  <=  MAXSLOADSPT); 

H$BYTE(CTR)  *  '  '; 

CTR  *  CTR  +  IS 

end; 

IF  FLOAT$VALUE  <>  'Z'  THEN 

t 

»  r 

2  e? 
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HSBYTE(CTR  :=  CTR  -  1)  -  floatsvalue; 
IT  SIGN (FLOATSVALUE )  TEEN 
PSIT$SI5N  =  CTRJ 

end; 

end; 

DO  CTR  =  0  TO  LAST$IOAD; 

I?  HSBYTE(CTB)  =  'O'  THEN 
H$BTTE  (CTR)  =  'Z'f 

ELSE 

IF  HSBYTE(CTR)  *  AND 

I$BTTE(CTR  -  1)  =  '*'  THEN 
H$BTTE(CTR)  =  '*'? 

end; 

DO  CTR  =  LAST$LOAD  +  1  TO  MAXS LOADS PT; 

IF  H$BYTE(CTR)  *  OR  HSBYTE(CTR)  *  '$'  OR 

SIGN(H$BYTE(CTR) )  OR  HSPYTE(CTR)  =  'O'  TFFN 
ESBYTE(CTR)  =  '0'? 

end; 

IF  PSITSSIGN  <  C$BYTE(6)  TEEN 

IF  E$BYTE(PSIT$SIGN )  *  '+'  THEN 
H$BYTE(PSIT$SIGN)  *  SIGN$OUT; 

ELSE 

IF  SIGN  SOOT  =  '+'  THEN 

do; 

IF  H$BYTE( PS IT$S IGN )  <>  '-'  TEEN 
H$BYTE(PSIT$SIGN  +  1)  «  '  '; 
ESBYTE(PSITSSIGN)  *  '  '; 

end; 

CALL  INC$PTR(12); 

end  kovesnumsedited; 


/#  * 


INPOT-OUTPUT  ACTIONS  **********/ 


RUFF$PTR 

ADDRESS f 

BUFF$BYTE 

BASED 

BUFFS PTR  (1) 

BYTE, 

BUFFSEND 

ADDRESS  , 

BUFFSLENGTH 

LIT 

'128', 

BUFFSTART 

ADDRESS, 

CHAR 

BYTE, 

CONS BUFF 

ADDRESS 

INITIAL  (P0H), 

CONSBYTE 

BASED 

CON$BUFF 

BYTE, 

CON$ INPUT 

ADDRESS 

INITIAL  (e2H), 

CONTROLS FLAG 

BYTE 

INITIAL  (FALSE) 

f 

CURRENT$FLAG 

BYTE, 

EOF$FLAG$OFFSET 

LIT 

'36', 

EXTENTSOFFSET 

LIT 

'12', 

FCB$ADDR$A 

BASED 

CURRENTSFCB  (1) 

ADDRESS . 

FCBSBYTESA 

BASED 

CURRENTSFCB  (1) 

BYTE. 

FLAGSOFFSET 

LIT 

'33', 

HIGHSFALUE 

LIT 

'0FFH', 
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INVALID 

BYTE, 

PAG 

LIT 

'22',  /*  CODE  FOR  PAGE  */ 

PTR$ OFFSET 

LIT 

'17'. 

REC$NO 

LIT 

'32', 

REWRITESFLAG 

BYTE 

INI TIAL (0H ) , 

TERMINATOR 

LIT 

'1AE  ', 

TOPSOFSPAGE 

LIT 

'0CH', 

VARSEND 

LIT 

'CR', 

WTF 

LIT 

'48';  /*  CODE  FOR  WRITE  */ 

ACCEPTS  PROCJ 
CALI  CRLF; 

CALL  PRINT$CHAR(3FH); 

CALL  FILL(C0N$INPUT,C$BYTE(2) , '  ')} 

CON$BYTE  *  128* 

CALL  READ(CON$BUFF); 

CALL  MOVE (CON $ INPUT , RES ( C$ADDR (0 ) ) ,C$BYTF(2) ) J 
CALL  INC$PTR(3)  * 

END  ACCEPT? 

DISPLAY:  PROCJ 

DCL  B$CNT  BYTE; 

BASE  ■  RES ( C$ADDR ( 0  ) ) J 

IF  NOT  C$BYTE(3)  THEN  CALL  CRLF; 

B$CNT  «  C$BYTE(2); 

DO  CTR  »  0  TO  B$CNT  -  U 

CALL  PRINT$CHAR(B$BYTE(CTR)); 

end; 

CALL  INC$PTR(4); 

END  display; 

GETSFILESTYPEs  PROC  BYTE; 

BASE  -  C$ADDR(0); 

RETURN  B$BYTE(FLAG$OFFSET); 

END  get$file$type; 

SETSFILESTYPEs  PROC (TYPE); 

DCL  TYPE  BYTE? 

BASE  -  C$ADDR(0); 

IF  GET$FILE$TYPE  <>  0  THEN  CALL  ?ATAL$ERROR( 'OE' ) J 
B$BYTE(FLAG$OFFSET)  -  TYPE; 

END  set$file$type; 

SET$I$Os  PROC; 

inyalid  -  false; 

IF  C$ADDR(0)  ■  CURRENTSFCB  THEN  RETURN; 

/*  STORE  CURRENT  POINTERS  AND  SET  INTERNAL  WPITF  MARK  V 
BASE  -  current$fcb; 

FCB$ ADDR$A( PTR$OFFSET )  «  BUFFS PTR; 
?CB$BYTE$A(FLAG$OFFSET)  -  currentsflag; 

/*  LOAD  NEW  VALUES  */ 
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BUFFSEND  «  (BUFFSSTART  (CURRENTSFCB  :=  CSADDR(0))  + 
STARTSOFFSET)  ♦  BUFFSLENGTH; 

CURRENTS  FLAG  »  FCB$BYTESA(FLAG$OF?SET) J 
BUFFSPTR  »  FCBSADDRSA(PTRSOFFSET); 

END  SET$I$0» 

0PEN$FILE:  PROC (TYPE); 

DCL  TYPE  BYTE; 

CALI  SET$FHE$TYPE(TYPE); 

CURRENTSFCB  -  C$ADDR(0); 

FCB$BYTE$A(SXTENT$OFFSET)  =  0; 

CTR  »  OPEN(CUBRENT$FCB); 

DO  CASE  TYPE  -  1» 

/*  INPUT  */ 

do; 

I?  CTR  *  255  THEN  CALL  FATAL$ERPOP.(  'NF'  ) ; 

end; 

/*  OUTPUT  V 

do; 

call  delete; 

CALL  MAXE(C$ADDR(0)); 

end; 

;  /*  CASE  2  NOT  USED  */ 

/*  1-0  */ 
do; 

IF  CTR  ■  255  THEN  CALL  FATAL$ ERROR (  'NF' ) ; 

end; 

end;  /*  DO  CASE  TYPE  -  1  */ 

FCB$BYTE$A(REC$NO)  »  0;  /*  SET  THE  RECORD  NUMBER  IN  FCB  */ 
?CB$BYTE$A(EOF$FLAG$OFFSET)  »  FALSE;  /*  SET  THE  EOF  OFF  */ 
BUFF$END  «  (BUFFSSTART  !*  ( CURRENTSFCB  +  STARTSOFFSET) )  ♦ 

buffslengte; 

CURRENT$FLAG  *  FCB$BYTE$A( ?LAG$OFFSET ) ; 

BUPF $PTR,FCB$A DDR $A (PTRS OFFSET )  «  BUFF$START  -  i; 

CALL  INC$PTR(2); 

END  opfn$file; 

WRITE$MARX :  PROC  BYTE; 

RETURN  ROL( CURRSN TSFLAG , 1 ) » 

end  writesmarx; 

SET$VRITE$MARK:  PROC; 

CURRIN TSFLAG  ■  CURRENTS FLAG  OR  80H; 

END  setswriteskark; 

WRITESRECORD :  proc; 

CALL  setsdma; 

CURRENTSFLAG  -  CURRENTSFLAG  AND  0FH; 

IF  (CTR  :»  DISKSWRITE)  »  0  THEN  RETURN; 

CALL  PRINTS ERROR( 'V8'); 

INVALID  -  TRUE; 
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END  ¥RITT$RECORD; 

READSRECORD:  PROC; 

CALL  SETSDMA; 

IP  ¥RITE$MARE  THPN  CALL  ¥RITE$RECORD ; 

IP  (CTR  :■  DISK$READ)  =  0  THEN  RETURN; 

IP  CTR  «  1  THEN  FCB$BYTE$.4(EOF$FLAG$OFFSET)  =  TRUE; 

INVALID  *  TRUE# 

end  readsrecord; 

READ$BYTE:  PROC  BYTE; 

IP  (PUFF$PTR  :»  BUFF$PTR  +  1 )  >*  RUFPENE  THEN 

do; 

CALL  read$record; 

IP  ?CB$BYTE$A(EOF$PLAG$OFFSET)  TEEN 

RETURN  terminator; 

3U?F$PTR  «  3UPP$START; 

end; 

RETURN  BUPP$BYTE(0); 

END  READ$3YTE; 

¥RITE$BYTE:  PROC  (CHAR),* 

DCL  CHAR  BYTE; 

IP  (BUPF$PTR  :*  BUFF$PTR+1)  >»  BUPP$END  THEN 

do; 

CALL  ¥RITE$RECORD; 

BUFF$PTR  -  3UPP$START? 

IF  RE¥RITE$FLAG  THEN 

do; 

CALL  read$record; 

PCB$BYTE$A(REC$NO)  «  FCB*BYTE$A (REC$NO )  -  i; 

end; 

end; 

CALL  SET$VRITE$MARj; 

BUPF$BYTE(0 )  «  CHAR; 

END  write$byte; 
write$end$mare:  proc; 

CALL  VRITE$BY7E(CR); 

CALL  ¥RITE$BYTE(LP); 

END  ¥RITE$END$MARI; 

READ$END$MARK:  PROC; 

IP  (PEAD$BYTEOCR)  OR  (RIAD$BYTEOLF)  THEN 
CALL  PRINT$ERR0R('EM'); 

END  rsad$end$mark; 

READ$YARI ABLE :PROC * 

CALL  SET$I$0; 

BASE  -  C$ADDR(2); 

CALL  PILL(C$ADDR(2) ,C$ADDR( 1 ) , *  '); 
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DO  ASCTR  «  0  TO  C$ADDR(1)  -  1? 

IF  (CTR  :=  READSBYTE)  »  VARSEND  THEN 
DO? 

CTR  «  READ$BTTE? 

RETURN ? 

END? 

IE  CTR  «  TERMINATOR  THEN 
DO? 

FCB$BYTE$A(EOF$ELAG$OFFSET)  =  TRUE 
RETURN? 

END? 

B$BYTE(A$CTR)  «  CTR? 

END? 

CALI  READ$END$MARE? 

END  RSAD$TARIABLE? 

WRITESVARlABLE:  PROC? 

DCL  COUNT  ADDRESS? 

CALL  SET$I$0? 

BASE  *  C$ADDR(1 )? 

COUNT  *  C$ADDR(2) ? 

DO  WHILE  ( (B$BTTE(COUNT  :=  COUNT  -  1)  *  '  ') 

AND  (COUNT  <>  0))? 

END? 

DO  A$CTR  «  0  TO  COUNT? 

CALL  VRITE$BYTE(B$BYTE(A$CTR ) ) ? 

END? 

CALL  WRITE$END$MARK? 

END  WRITE$VARIABLE? 

READ$TO$MEMORY:  PROC? 

DCL  CHAR  BYTE? 

BASE  *  C$ADDR (1 )  ? 

DO  ASCTR  »  0  TO  C$ADDR(2)  -  1? 

IE  (CHAR  :*  READ$BYTE)  »  TERMINATOR  THEN 
DO? 

IN VALID, ECB$ BYTES A (EOE$ FLAG $OEISET) 
RETURN? 

END? 

ELSE  B$BYTE(A$CTR)  =  CHAR? 

END? 

CALL  READ$END$MARE? 

END  READSTOS MEMORY? 

WRITE$FROM$MEMORY:  PROC? 

BASE  -  RES(C$ADDR(1 ) ) ? 

DO  A$CTR  «  0  TO  C$ADDR(2)  -  1? 

CALL  WRITE$BYTE(B$BYTE(A$CTR))? 

END? 

IE  CONTROLS FLAG  THEN 

CALL  WRITISBYTE(CR)? 


ELSE 

CALL  write$end$mare; 

END  WRITE$FROM$MBMORY; 

/*********  RANDOM  1-0  PROCEDURES  ********/ 
SET$RAN$POINTER :  PROCJ 

/*  THIS  PROCEDURE  READS  THE  RANDOM  KET  AND  COMPUTES 
WHICH  RECORD  NEEDS  TO  BE  AVAILABLE  IN  THE  BUEFER 
THAT  RECORD  IS  MADE  AVAILABLE  AND  THE  POINTERS 
SET  FOR  INPUT  OR  OUTPUT  */ 

DCL  (BTTE$COUNT, TEMP, RECORD)  ADDRESS, 

EXTENT  BITE? 

IF  VRITESMARK  THEN  CALL  WRITE* RECORD? 

TEMP  »  CONVERT$TO$HEX (C$ADDR (3 ) ,C$BTTE(8) ) i 
IF  TEMP  «  0  THEN 

do; 

INVALID  =  TRUE,* 

RETURN ; 

end; 

BTTESCOUNT  »  (C$ADDR(2)  +  2)  *  (TEMP  -  1); 

RECORD  «  SHR(BTTE$COUNT,7); 

EXTENT  -  SHE (RECORD,?); 

IF  EXTENT  <>  FCB$BTTE$A(EXTENT$OFFSET )  THEN 

do; 

CALL  CLOSE(C$ADDR{ 0) ) J 
FCB$BTTE$A(EXTENT$OFFSET )  »  EXTENT; 

IF  OPEN(C$ADDR(0) )  *  255  THEN 

do; 

IF  SHR(CURRENT$FLAG,1)  THEN 
CALL  MAEE(C$ADDR(0)); 

ELSE 

do; 

INVALID  »  TRUE; 

FCB*BTTE$A(EXTENT$OFFSET )  *  0; 

IF  OPEN(C$ADDR(0) )  »  255  THEN 
CALL  FATAL*ERBOR( 'OP')J 

end; 

end; 

end; 

BUFF$PTR  -  (BTTE$COUNT  AND  7FH)  ♦  BUFF$START  -  i; 
FCB$BTTE$A(32)  -  LOV(RZCORD)  AND  7FH; 

CALL  read$record; 
end  set$ran$pointer; 

GET*REC* NUMBER*  PROC  ADDRESS; 

DCL  (RECORD, LOGICAL$REC$NUMvBTTE$COUNT)  ADDRESS; 

RECORD  *  FCB$BTTE$A(EXTENT$OFFSET); 

RECORD  -  SHL(REC0RD,7)  ♦  FCB$BTTE$A (REC$NO); 

IF  NOT  SHR(CURRENT$FLAG,1)  TEEN  RECORD  -  RECORD  -  i; 
BTTE$COUNT  -  SHL(RECORD,7)  ♦  ( (BUFF$PTR  ♦  1 )-BUFF$START) ; 


LOG I CA L$REC  $NUM  -  (BYTE$COUNT  /  (C$ADDR(2)  ♦  2))  +  1? 
RETURN  LOGICAL$RFC$NUMJ 
END  GET$REC$NUMBER; 

SET$RELATIVE$KET :  PROC? 

DCL  (REC$NUM,  X)  ADDRESS, 

( I  ,C NT )  BITE , 

J(4 )  ADDRESS  DATA  (10000,1000,100,10), 

BU7? (5 )  BITE? 

REC$NUM  *  get$rec$number; 

DO  I  -  0  TO  3? 

CNT  «  0J 

DO  WHILE  REC$NUM  >*  (E  :  =  J(I))i 
REC$NUM  *  REC$NUM  -  KJ 
CNT  -  CNT  +  1? 

end; 

BCPF ( I )*CNT  +  '0'; 

end; 

BU??(4)  «  REC$NUM  +  '0'i 
IF  (I  :»  C$BTTE(8) )  <=  5  THEN 

CALL  MOVE(.BUFF  +  5  -  I ,RES(C$ADDR(3) ) ,1) * 

ELSE 

do; 

CALL  FILL  ( RES  ( C  $ADDR  ( 3  ) ) ,  I  -  5,'0'); 

CALL  MO VE ( . BUFF , RES ( C $ ADDR ( 3 ) )  +  I  -  5,5); 

end; 

END  set$relative$ket; 

WRT$EMPTY$REC  s  PROC; 

DO  A$CTR  -  1  TO  C$ADDR(2) ; 

CALL  WRITE$BTTE(HIGH$VALUE); 

end; 

CALL  write$end$mark; 

END  WRT$EMPTT$REC; 

VRI TE$ DUMMY $RECS :  PROC ( DI FIERENCE ) ; 

DCL  DIFFERENCE  ADDRESS,  COUNT  BITE; 

DO  COUNT  *  1  TO  difference; 

CALL  VRT$EMPTY$REC; 
end; 

END  VRITE$DUMMT$RECS; 

BACK$ONE$EXTENT :  PROC! 

CALL  CLOSE(C$ADDR(0)); 

IF  (FCB$BYTE$A(EXTENT$OFFSET)  :« 

FCB$BYTE$A(EXTENT$OFFSET)-l)“255  THEN 
CALL  FATAL$ERROR( 'W7') ; 

I?  OPEN(C$ADDR(0 ) )  -  255  THIN 

do; 

CALL  FATAL$ERROR ( 'OP ' ) » 

INVALID  -  TRUE! 


return; 

end; 

FCB$BYTB$A(REC$NO)  «  127; 

end  back$one$extent; 

BACK$ONE$RECORD:  PROCJ 

IF(BUFF$PTR  BUFF$PTR  -  (C$ADDH(2)  +2))  >= 
BU?F$START  -  1  THEN 

do; 

FCB$BYTE$A(REC$NO)  =  FCB$BYTE$A (REC$NO)  -  1? 
RETURN ; 

end; 

BUFF$PTR  »  BUFF$START  -  BUFF$PTR; 

DO  WHILE  BUFF$PTR  >  129; 

BUFF$PTR  -  BUFF$PTR  -  128; 

FCB$BYTE$A(REC$NO)  =  FCB$BYTE$A (RECSNO)  -  1? 

end; 

BUFF$PTR  -  BUFf$END  -  BUFF$PTR ; 

FCB$BTTE$A(REC$NO )  «  FCB$BTTE$A(REC$NO )  -  2; 

IF  FCB$BYTE$A(REC$NO)  >  127  THEN 

do; 

CALL  BACK$ONE$EXTENT; 

IF  INVALID  THEN  RETURN; 

CALL  read$record; 

FCB$BTTE$A(REC$NO)  *  127; 

end; 

ELSE 

do; 

call  read$record; 

FCB$BTTE$A(REC$NO)  *  FCB$BYTE$A (REC$NO )  -  15 
END; 

END  back$one$record; 
revrite$seoj  proc(flag); 

DCL  FLAG  BTTE5 

call  back$one$record; 

REWRITES FLAG  3  TRUE; 

IF  FLAG  THEN  CALL  WRITE$FROM$MEMORY ; 

ELSE  CALL  WRT$EKPTT$REC;  /*  THIS  IS  A  DELETE  *7 

call  writisrecord; 

IF  FCB$BYTESA(REC$NO)  *  0  THEN 
CALL  back$one$extent; 

ELSE 

FCB$BYTE$A(REC$NO)  «  FCB$BTTE$A (REC$NO)  -  l; 
REWRITES FLAG  -  FALSE? 

call  readsrecord; 

END  rewritesseq; 

CHECK SDIFFERENCE*  PROC5 

DCL  (DIFFERENCE, NEXT$RECORD, NEXTSKET)  ADDRESS? 
NEXTSRECORD  *  GET$REC$N UMBER? 
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N EXT $ SET  -  C0MVERT$T0$HEX(C$ADDR(3)  tC$BTTE(6) ) » 

IX  NEXT$RECORD  >  NEXT$XET  THEN  CALL  FATAL $ERBOR  ( 'W2' )  f 
DIFFERENCE  «  NEXT$KET  -  NEXT$REC0RD5 

IF  DIFFERENCE  >  0  THEM  CALL  VRITE$DUMMT$RECS(DIFFERENCF) i 

END  check$difference; 

/»************  MOVES  **************/ 

LOAD$INC:  PROCf 

H$BTTE(CTR)  *  BiBTTE(CTRl) » 

CTR1  *  CTR1  ♦  1J 
CTR  *  CTR  ♦  15 
END  LOAD  $  INC  $ 

CHECX$EDIT :  PROC(CHAR); 

DCL  CEAR  BTTEJ 

IF  (CHAR  »  '0')  OR  (CHAR  *  '/')  THEN  CTR  *  CTR  ♦  If 
ELSE  IF  CHAR  «  'B'  THEN 
DOf 

H$BYTE(CTR)  •  '  '} 

CTR  «  CTR  +  If 

end; 

ELSE  IF  CHAR  -  'A'  THEN 

do; 

IF  NOT  LETTER(B$BTTE(CTR1 ))  THEN 
CALL  PRINT$ERROR('IC')f 
CALL  LOADSINC; 

end; 

ELSE  IF  CHAR  »  '9'  THEN 

do; 

IF  NOT  NUMERIC  ( 3$BTTE(CTR1 ) )  THEN 
CALL  PRINT$ERROR('IC'); 

CALL  LOADSINC; 

end; 

ELSE  CALL  LOAD$INCf 

END  checesedit; 

/***********  MACHINE  ACTIONS  *  *  *********/ 

STOP:  PROC; 

CALL  crlf; 

DO  CTR  «  1  TO  4f 

CALL  PRlNT$CEAR(ERROR$CTR(CTR)); 

end; 

CALL  MON1 (9, . ( '  EXECUTION  ERRORS*')); 

CALL  booter; 
end  stop; 

/******************************* 
THE  PROCEDURE  BELOV  CONTROLS  THE  EXECUTION  OF  THE  CODE. 


IT  DECODES  EACH  OP-CODE  AND  PERFORMS  TEE  ACTIONS 
*******#**«***«******»*#*******/ 
EXECUTE:  PROCf 

DO  forever; 

do  case  get$op$code; 

;  /*  CASE  ZERO  NOT  USED  */ 

/*  01s  ADD  V 

CALL  add; 

/*  02:  SUB  */ 

do; 

SIGN0<0)  «  SIGN0(0)  XOR  1? 

CALL  ADD; 

end; 

/*  03:  MUL  */ 

do; 

dcl  (i,  x)  byte; 

call  SET$MULT$DIVJ 

BASE  =  .R0J 

CALL  SHIFT$RIGHT(17)J 

BASE  *  .HU 

CALL  SHIFT$RIGHT(1); 

DEC$PT2  =  DEC$PT0  +  DFC$PTi; 

I  *  10J 

DO  INDEX  =  1  TO  9! 

CALL  MULTIPLT(R1<I  :*  I  -  1)  AND  0FH) ; 
CALL  MULTI PLY (S RR (Rl (I ) ,4) ) * 

end; 

BASE  »  .R2; 

CALL  SHIFT$LEFT(17); 

IF  OVERFLOW  THEN 

IF  (X  :»  CTR  ♦  DEC$PT2)  <  17  THEN 
DEC$PT2  »  0; 

ELSE 

do; 

DEC$PT2  »  X  -  17; 

OVERFLOW  *  false; 
end; 

REG$LENGTH  -  10> 

CALL  checs$result; 

end; 

/*  04:  DIV  */ 

CALL  divide; 

/*  05:  NEG  •/ 

BRANCH$FLAG  =  NOT  BRANCH$FLAG; 

/*  06:  STP  */ 

CALL  STOP; 

/*  07:  STI  V 

CALL  storesimmsdiate; 

/*  08:  EXT  v 


IF  RTN$BASE  <  HI$FREE$MEK  THEN 

do; 

PROGRAM$COUNTER  «  RTN $PTR(0 ) » 
L0W$0??SE?  *  RTN$PTR(1  )* 

HI$OFFSET  =  RTN$PTR(2); 

RTN $ BASE  =  RTN$BASE  +  6; 

call $t op  »  call$base; 

CALL$BASE  =  CALL$PTR(0); 

Pft|T>« 

/*  09s  RND  */ 

do; 

IF  NOT  OVERFLOW  THEN 

do; 

BASE  s  ,R2 ; 

IF  (DEC$PT2  -  C$BTTE(0)  )  >  0  THEN 

do; 

CALL  SHIFT$RIGHT(DEC$PT2 
CBBTTB(0)); 

DEC$PT2  *  C$3TTE(0); 

end; 

ELSE 

do; 

CALL  SHIFTS LEFT (C$ BYTE (0 ) 
DECPT2); 

DEC$PT2  -  DECSPT2  ♦  CTR; 

end; 

call  checksresult; 
end; 

CALL  INC$PTR(1); 

end; 

/*  10s  RET  */ 

do; 

IF  C$ADDR(0)  <>  0  THEN 

do; 

A$CTR  «  C$ADDR(0); 

C$ADDR(0)  =  0; 

PROGRAMS COUNTER  =  A$CTR; 

end; 

ELSE  CALL  INC$PTR(2); 

end; 

/*  Us  CLS  */ 

do; 

CALL  SET$I$0; 

IF  ¥RITE$MARK  THEN 

do; 

IF  NOT  SHR ( CURREN T$ FLAG  * 2 )  THEN 
CALL  WRITESBYTE( TERMINATOR)? 

CALL  vritesrecord; 
end; 

ELSE  CALL  SETSDMA? 

CALL  CLOSE(C$ADDR(0)); 
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CURREN  T$FLAG , FCB$BYTE$A ( FLAG$0FFSET )  =  0? 
CALL  INC$PTR(2)J 

end; 

/*  12:  SER  V 

IF  OVERFLOW  THEN 

do; 

CALL  INC$PTR(3); 

OVERFLOW  =  FALSE? 

end; 

/*  13:  BRN  */ 

PROGRAM$COUNTER  =  C$ADDR(0)J 

/*  14:  OPN  */ 

do; 

CALL  OPEN$FILE(l); 

CALL  read$record; 

end; 

/*  15:  OP1  */ 

CALL  OPEN $FILE( 2 ) ; 

/*  16:  0P2  */ 

do; 

CALL  OPEN  $FILE (4  ) ; 

CALL  read$record; 

end; 

/*  17:  RGT  */ 

do; 

IF  NOT  SIGN0(2)  THEN 

BRANCH$FLAG  *  NOT  BRANCESFLAGJ 
CALL  COND$BRANCH(0); 

end; 

/*  18:  RLT  */ 

do; 

IF  SIGN0(2)  AND  NOT  R2$ZER0  THEN 
BRANCH$FLAG  *  NOT  BRANCH$FLAG; 

CALL  COND$BRANCH(0); 

end; 

/*  19:  REQ  */ 

do; 

IF  R2$ZER0  THEN 

BRANCH$FLAG  =  NOT  BRANCH$FLAG; 

CALL  COND$BRANCH(0); 

end; 

/*  20:  INV  */ 

CALL  INCR$OR$BRANCH( INVALID); 

/*  21:  EOR  •/ 

CALL 

INCR$OR $BRAN CH( FCB$BTTE$A (EOF$FLAG$OFFSET ) ) 

/*  22:  PAG  V 

do; 

DCL  I  bite; 

CALL  SET$I$05 
IF  C$BITE(2)  <  100  THEN 


DO  I  =  1  TO  C$BYTE(2)J 
CALL  VRITESBYTE(LF); 

end; 

ELSE 

CALL  WRITE$BYTE(TOP$OI$PAGE); 

IF  C$BYTE(3)  *  VT*  '"HEN 
CONTBOLSFLAG  *  a;RUE; 

CALL  INC$PTR(3); 

end; 

/*  23:  ACC  */ 

CALL  accept; 

/*  24:  STD  */ 

do; 

TEMP  =  C$BYTE(3); 

C$BYTE(3)  =  0; 

CALL  display; 

CALL  PRINT(.(LF /OPERATOR  ENTER  A  <CR>  TO 

CONTINUES')); 

CALL  PRINT(  .(TAB/  OR  ENTER  AN  "s"  TO 

TERMINATE. $')); 

CHAR  «  0; 

DO  WHILE  (CHAR  <>  CR)  AND  (CHAR  <>  'S'); 
CALL  PRI NT(.(CR,LF, '?$')); 

CHAR  =  MON2(lf0); 

end; 

IF  CHAR  =  CR  THEN 

do; 

PROGRAMSCOUNTER  «  PROGRAMSCOUNTER  -  1 
C$BYTE(0)  =  TEMP; 

end; 

ELSE  CALL  STOP; 

end; 

/*  25:  LDI  */ 

do; 

C$ADDR(2)  = 

CONVERT$TO$HEX(RES ( C$ADDR(0) ) ,C$BYTE(2) )  +  1 
CALL  INC$PTR(3); 

end; 

/*  26:  DIS  */ 

CALL  display; 

/*  2?:  DEC  */ 

do; 

IF  C$ADDR( 0)  <>  0  THEN 

C$ADDR(0)  *  C$ADDR  (0)  -  1*, 

IF  C$ADDR(0)  -  0  THEN 

PROGRAM$COUNTER  =  C$ADDR(1); 

ELSE  CALL  INC$PTR(4); 

end; 

/*  28:  STO  V 

do; 


CALL  STORESNUMERIC; 


CALL  1NC$PTR(  4) » 


end; 

/*  29!  ST1  */ 

do; 

CALL  STORE$NUMERIC; 

CALL  SET$ZONE(HES (C$ADDR (0) ) ) » 

end; 

/*  30!  ST2  */ 

do; 

CALL  STORE$NUKERIC; 

CALL  SET$ZONE{RES(C$ADDR(0))  +  CSBYTE(2)  -  1) 

end; 

/*  31 !  ST3  */ 

do; 

CALL  CHECK$DECIKAL; 

BASE  =  RES ( C$ADDR( 0 ) )  +  C$BYTE(2)  -  1? 

CALL  STORE$AS$CHAR (C$BY?F (2 )  -  l)*» 

CALL  SET$SIGN$SEP(RES(C$ADDR(0))); 

end; 

/*  32 l  ST4  */ 

do; 

CALL  CBECK$DEC1»AL; 

BASE  »  RES (C$ADDR (0 ) )  +  C$BYTE(2)  -  2t 
CALL  STORE$AS$CHAR (C$BYTE (2)  -  1); 

CALL  SIT$SIGN$SEP 

(RES(CUDDR(0))  +  C$BYTE(2)  -  1); 

end; 

/*  33l  ST5  V 

do; 

CALL  ceece$decimal; 

IP  SIGN0(2)  «  0  THEN 

R2(9)  »  R2(9)  OR  01H,* 

IF  C$BYTE(4)  <>  SER  OR  NOT  OVERFLOW  TEEN 

do; 

CTR  *  C$BYTE(2 )  /  2  +  i; 

CALL  MOVE 

(.R2  ♦  10  -  CTR « RES ( C$ADDR( 0) ) ,CTR ) 

end; 

CALL  INC$PTR(4); 

end; 

/*  34i  LOD  */ 

CALL  LOAD$NUM$LIT; 

/*  35!  LD1  */ 

CALL  LOAD$NUMERIC; 

/*  36!  LD2  */ 

do; 

HOLD  «  RES(CADDR(0) )» 

IF  CHECK$FOR$SIGN(H$BYTE(0) )  TIEN 

do; 

CALL  SET$LOAD(POSITIVE); 

CALL  LOAD$NUMBERS (C$ADER(0) ,C$BYTE(2 ) ) » 


end; 

ELSE 

do; 

TEMP  *  H$*YTE(0); 

CALL  SET$LOAD(NEGITIVE)J 
CALL  LOAD$NUMBERS 

(C$ADDR(0 )  +  1,C$BYTE(2)  -  1); 
CALL  LOAD$A$CHAR (TEMP  -  ZONE); 

end; 

end; 

/*  37:  LD3  */ 

do; 

DCL  I  bite; 

HOLD  »  RES ( C$ADDR ( 0 ) ) » 

IP  CHECK $FOR$S IGN ( 

CTR  :  =  H$BYTE( I  :«  C$BTT£(2)  -  1))  THEN 

do; 

CALL  SET$LOAD (POS ITIVE) ; 

I  =  I  +  15 

end; 

ELSE 

do; 

CALL  SET$LOAD(NEGITI¥E); 

CALL  LOAD$A$CHAR(CTR  -  ZONE)*, 

end; 

CALL  LOAD$NUMBERS(C$ADDR(0),I); 

end; 

/*  38:  LD4  »/ 

do; 

HOLD  «  RES(C$ADDR(0)); 

IP  (H$BTTE(0)  *  '  +  ')  THEN 

CALL  SET$LOAP(POSITIVE); 

ELSE  CALL  SET$LOAD (NEGITIVE } ; 

CALL  LOAD$NUMBERS(C$ADDR(0)  ♦  1. 

C$BTTE(2)  -  I)? 

end; 

/♦  39:  LD5  V 

do; 

HOLD  «  RES (C$ADDR ( 0 ) ) * 

IF  H$BTTE( C$BTTE(2 )  -  1)  »  THEN 
CALL  SET$LOAD(POSITIVE); 

ELSE  CALL  SETHOAD  (NEGITIVE) ; 

CALL  LOAD$NUMBEBS(C$ADDR(0),C$BTTE(2)  -  1); 

end; 

/*  40:  LD6  */ 

do; 

DCL  I  BITE; 

HOLD  «  RES(C$ADDR(0)); 

IF  H$BTT£  (I  :»  C$BTTE(2)  /  2)  THEN 
CALL  SET$LOAD( NEGITIVE); 

ELSE  CALL  SET$LOAD(POSITIVE) ; 


...J SSoiSSkiX 


302 


BASE  »  BASE  +  9  -  I? 

do  era  -  0  to  x; 

B$BTTE(CTR)  =  H$BTTE( CTR) i 

end; 

BiBTTE(I)  -  B$BYTE ( I )  AMD  0F0H; 

CALL  INC$PTR(5)J 

end; 

/*  41:  PER  */ 

do; 

BASS  *  C$ADDR( 1 )  +  1J 
B$ADDR( 0)  =  CiADDR (2)5 
PROGRAM $COON TER  =  C$ADDR(0)J 

end; 

/*  42:  CNU  */ 

CALL  comp$num$unsigned; 

/*  43:  CMS  v 

CALL  comp$num$sign; 

/*  44:  CAL  */ 

CALL  comp$alpha; 

/*  45:  RVS  */ 

do; 

CALL  SET$I$0; 

IF  NOT  SHR(C0RRENT$FLAG,2 )  THEN 
CALL  FATALSERROR ( 'V6 ' ) ; 

IF  MOT  FCB$BTTE$A(EOF$FLAG$OFFSET)  TEEN 
CALL  REVRITE$SEQ(1 ) J 
CALL  IMC$PTR(6); 

end; 

/*  46:  DLS  */ 

do; 

CALL  SET$I$o; 

IF  NOT  SHR(CURRENT$FLAG,2)  THEN 
CALL  FATAL$ERROR ( 'W6  ' ) » 

IF  NOT  FCB$BTTE*A(EOF$FLAG$OFFSST)  TEEN 
CALL  REVRITE$SEO(0); 

CALL  INC$PTR(6); 

end; 

/*  47:  RDF  */ 

do; 

CALL  SET$I$o; 

IF  NOT  CURRENT$FLAG  THEN 
CALL  FATAL$ERROR ( 'W5 ' ) ; 

IF  NOT  FCB$BTTE$A(EOF$FLAG$OFFSET)  THEN 
CALL  READ$TO$MEMORT » 

CALL  INC$PTR(6); 

end; 

/*  46:  WTF  */ 

do; 

IF  C$BTTE(6)  «  PAG  THEN 
CONTROL$FLAG  -  TRUE! 

CALL  SET$I$0; 


303 


IF  MOT  SHR(CURRENT$FLAG,1 )  THIN 
CALL  FATAL$ERROR ( 'W3 ' ) » 

CALL  write$from$memory; 

CALL  INC$PTR(6); 

CONTROL$FLAG  *  FALSE? 

END? 

/*  49:  RVL  */ 

do; 

call  readsvariable; 

CALL  INC$PTR(6); 

end; 

/*  50:  WVL  */ 

do; 

call  vritesvariable; 

CALL  INC$PTR(6); 

end; 

/*  51:  SCR  */ 

do; 

SU3SCRIPT(C$BTTE(?) )  *  C$ADDR(0)  ♦  C$ADDR(l)  * 
(C0NVERT$T0$BEX(C$ADDR(2) ,C$BTTE(6) )  -  1); 
CALL  INC$PTR(8); 
end; 

/*  52:  SGT  */ 

CALL  STRING$COMPARE(l) ; 

/*  53:  SLT  */ 

CALL  STRING$COMPARE(0); 

/*  54:  SEO  *7 

CALL  STRING$C0MPARE(2); 

/*  55:  MOV  */ 

do; 

CALL  MOVE  (RES  (CHDDR(l))  .RES  ( C$ADrR(  0) )  , 

C$AIER (2 ) ) ; 

IF  C$ADDR(3)  <>  0  THEN 

do; 

CALL  FILL(RES (C$ADDR (0) )  +  C$AtDR(2). 

C$ADDR(3), FILLER); 

end; 

CALL  XNC$PTR(6); 

end; 

/*  56:  RRS  */ 

do; 

DCL  H$FLAG  BITE; 

H$FLAG  -  TRUE? 

CALL  SET$I$0? 

IF  SHR( CURRENT$FLAG .1 )  THEN 
CALL  FATAL$ERROR( 'W5')5 
DO  WHILE  (NOT  FCB$BTTE$A(EOF$FLAG$ OFFSET) ) 
AND  h$tlag; 

HSFLAG  »  FALSE? 

call  set$relative$ket; 
call  read$to$memory; 
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IP  B$BYTE(0)  *  HIGH$VALUE  THEN 
B$FLAG  «  TRUE*. 

end; 

CALL  INC$PTR(9); 

end; 

/*  57:  WRS  */ 

so; 

call  set$i$o; 

IP  NOT  SHR  ( C  tJRRE  NT  $ FLAG *  1 )  THEN 
CALL  PATAL$ERBOR('Wl'); 

CALL  check*difference; 

CALL  SET$RELATIVE$KEY; 

CALL  WRITE$FROM$MEKORY » 

CALL  INC$PTR(9); 

end; 

/*  58:  RRR  */ 

so; 

CALL  S£T$I$0; 

IP  SHR(CURRENT$FLAG,1 )  THEN 
CALL  PATAL$ERROR{ 'W5'); 

call  set$ran$pointer; 

IF  NOT  INVALID  THEN 

CALL  read$to$mekort; 

IP  INVALID  THEN 

FCB$BYTE$A(FOF$FLAG$OFFSET)  =  FALSE; 
CALL  INC$PTR(9); 

end; 

/*  59:  VRR  */ 

bo; 

DCL  DIFFERENCE  ADDRESS; 

CALL  SET$I$0; 

IF  SHR( CURRENT$FLAG ,1 )  THEN 

do; 

CALL  CHECE$DIFFERENCF; 

CALL  set$relative$xey; 
call  vrite$from$kekory; 
end; 

ELSE 

do; 

IF  SHR(CURRENT$FLAG,2)  THEN 

do; 

CALL  set$ran$pointer; 

IF  not  invalid  then 

IF  (BUFF$BYTE(1 ) )  «  BIG  HA  VALUE  THEN 

do; 

REVRITE$FLAG  »  TRUE? 
FCB$BYTE$A(REC$NO)  = 

FCB$BYTE$A(REC$NO)  -  l? 

CALL  VRITE$FROM$fWORY; 
REWRITE$FLAG  >  FALSE; 

end; 
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ELSE  CALL  FATAL$ERR0R('¥4'); 

ELSE  CALL  FATAL$ERROR  (  'W3  ' ) » 

end; 

end; 

CALL  INC$PTR(9); 

end; 

/*  60:  RWR  */ 

do; 

CALL  SET$I$0; 

IE  NOT  SHR(CURRENT$FLAG ,2  )  THEN 
CALL  FATAL$ERR0R('W6'); 

REWRITS$FLAG  *  TRUE; 

CALL  bace$one$record; 

IF  NOT  INVALID  THEN  CALL  WRITE$FROK$MEMORT 
REWRITE$FLAG  *  FALSE; 

CALL  INC$PTR<9); 

end; 

/*  61:  DLR  */ 

do; 

CALL  SET$I$0; 

IF  NOT  S2R( CORRENT$FLAG ,2  )  THEN 
CALL  FATAL$ERROR( 'W6')5 

CALL  set$ran$pointer; 

REWRITE$FLAG  *  TRUE; 

IF  NOT  INVALID  THEN 

do; 

FCB$BTTE$A (REC$NO )  - 

fcb$byte$a (recsno )  -  i; 

CALL  wrt$empty$rec; 

end; 

REWRITE$FLAG  *  FALSE; 

CALL  INC$PTR(9); 

end; 

/*  62:  WED  */ 

do; 

HOLD  -  RES(C$ADDR(0)); 

CALL  WOVE ( RES (C  $ADDR (3 ) ) ,H0Lr»C$ADDR(4 ) ) 
BASE  -  res(c$addr(i)); 

CTR,CTR1  *  0; 

DO  WHILE  ( CTR1  <  C$ADDR(2)) 

AND  (CTR  <  C$ADDR (4) ) » 

CALL  CHSCK$EDIT(H$BTTE(CTR) ); 

end; 

DO  WHILE  CTR  <  C$ADDR(4); 

IF  H$BTTE(CTR)  -  'l'  OR 
H$BTTE(CTR)  «  'A '  OR 
HSBTTE(CTR)  ■  '9'  THEN 
H$BYTE(CTR)  »  FILLER.* 

ELSE  IF  H$BYTE(CTR)  •  'B'  THEN 
H$BYTE(C?R)  -  '  '; 

CTR  «  CTR  ♦  1? 


end; 

CALL  INC$PTR(10)J 

end; 

/*  63:  MNE  */ 

CALL  MOVE$NUM$EDITED; 

/*  €4:  SBR  */ 

do; 

RTNSBASE  *  HTN$BASE  -  6; 

RTN$PTR(0)  ■  PROGRAM$COUNTER  +  6J 
RTN$PTR(1 )  »  LON$OFFSET; 

RTN$PTR (2 )  ■  HISOFFSET; 

LOW$OFFSET  *  C$ADDR(1); 

RISOFFSET  -  C$ADDR(2) » 

PROGRAM $CO0NTBR  *  C$ADDR(0)»* 

end; 

/*  65:  GDP  V 

do; 

DCL  OFFSET  BITE? 

OFFSET  -  C0NVERT$T0$HEX(R£S(C$ADDR(1)) . 

C$BYTE(1)) J 

IF  OFFSET  >  C$BYTE(0)  OR  OFFSET  <  1  THEN 

do; 

CALL  PRINT$ERROR('GD'); 

CALL  INC$PTR(SHL(C$BYTE(0) ,1)  ♦  4) 

end; 

ELSE  PROGRAM$COUNTER  *  C$ADDR (OFFSET  +  1 ) ; 

end; 

/*  66:  PAR  */ 

do; 

HOLD  =  CALL$TOP; 

CALLSTOP  =  CALL$TOP  ♦  SHL(C $ADDR(0 ) ,1 )  ♦  2 
IF  CALL$TOP  >  RTN$BASE  -  7  THEN 
CALL  FATALSERROR ( 'CO ' ) ; 

H$ADDR(0 )  -  CALL$BASE; 

DO  CTR  -  1  TO  C$ADDP(2); 

B$ADDR( CTR)  »  RES (C$ADDR( CTR) ) J 

'END; 

CALL$BASE  -  HOLD? 

CALL  INC$PTR(SHL(C$ADDR(0),1)  ♦  2^ J 

end; 

end;  /*  END  OF  CASE  STATEMENT  */ 

END;  /*  END  OF  DO  FOREVER  */ 

end  execute; 

/***«**«  PROGRAM  EXECUTION  STARTS  HERE  *******/ 

CALL  MOVE(00FCHf .HI$FREE$MEM,4); 

HI$FREI$MEM  -  MAX$M EMORY  -  KI$FREE$MEM; 

LOV$FREE$MEM  «  CODESSTART  ♦  LOWS FREES MEM  +  2 ; 

RTNSBASE  -  HI$FREE$MEM; 

CALL STOP, CALL$BASE  -  LOVSFREESMEM; 


CALL  PRlNT(.('NPS  MICRO-COBOL  INTERPRETER  VERSION  2.0$'))? 
CALL  PRINT( .( 'EXECUTION  BEGINS$ ' ) ) ; 

BASS  «  codf$start; 

PROGRAM$COUNTER  »  B$ADDR(0); 

call  execute; 
end; 


COMPUTER  LISTING  FOR  MO DOLE  R FADER  NPS  MICRO-COBOL 

$  TITLE('NPS  MICRO-COBOL  COMPILER  READER')  PAGEWIDTH(80) 
PAGELENGTH (60 ) 

READER:  DO? 

/*  COBOL  COMPILER  -  READER  */ 

/*  NORMALLY  LOCATED  AT  B000H  */ 

/*  GLOBAL  DECLARATIONS  AND  LITERALS  V 


/*  THIS  PROGRAM  IS  LOADED  IN  WITH  THE  PART  1  PROGRAM 
AND  IS  CALLED  WHEN  PART  1  IS  FINISHED.  THIS  PROGRAM 
OPENS  THE  PART2.COM  FILE  THAT  CONTAINS  THE  CODE  FOR 
PART  2  OF  THE  COMPILER,  AND  READS  IT  INTO  CORF.  AT 
THE  END  OF  THE  READ  OPERATION,  CONTROL  IS  PASSED  TO 
THE  SECOND  PART  OF  THF  PROGRAM.  */ 


DECLARE 

LIT  LITERALLY 

ADDR  ADDRESS 

DCL  LIT 

FCB(33)  BYTE 

0,0, 0,0, 0,0, 0,0 

I  ADDRESS , 

PROC  LIT 

START  LIT 


'LITERALLY', 

IN IT1AL( 100H) , 

'DECLARE', 

INITIALS, 'PART2  COM'. 
,0,0, 0,0, 0,0, 0,0, 0,0, 0,0,0) 


'PROCEDURE', 

'100H'? 


* 


M0N1 :  PROC (F, A)  EXTERNAL? 

DCL  F  BYTE,  A  ADDRESS? 
END  M0N1? 


M0N2:  PROC (F, A)  BYTE  EXTERNAL? 

DCL  F  BYTE,  A  ADDRESS? 

END  M0N2? 


BOOT:  PROC  EXTERNAL? 

END  BOOT? 

OPEN:  PROC(FCB)  BYTE? 

DCL  TCB  ADDRESS? 

RETURN  M0N2(15,FCB)? 

END  OPEN? 

READ:  PROC (ADDR)  BYTE? 

DCL  ADDR  ADDRESS? 

CALL  M0N1  (26, ADDR)?  /*  SET  DMA  ADDRESS  */ 

RETURN  M0N2  (20,.FCB)?  /*  READ,  AND  RETURN  ERROR  CODE  */ 
END  READ? 


309 


ERROR:  PROC(CODE); 

DCL  CODE  address; 

CALL  M0N1(2« (HIGH (CODE) ) )» 

CALL  MON1 (2 , (LOW ( CODE) ) ) • 

CALL  boot; 
end  error; 

/*  PROGRAM  EXECUTION  STARTS  HERE  */ 

CALL  MON1  (26.0100H); 

IP  OPEN(.ECB)  *  255  TEEN  CALL  ERROR ('02'); 

I  «  0100H; 

DO  VEILS  READ ( I )  *  0? 

I  «  I  +  0080H; 

end; 

CALL  M0N1  (26,  0080H);  /*  RESET  DMA  ADDRESS  V 

CALL  addr; 
end; 
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COMPUTE?  LISTING  FOR  MODULE  BUILD  NPS  MICRO-COBOL 


$  TITLE('NPS  MICRO-COBOL  COMPILER  BUILD')  PAGEWIDTH( e0 ) 
PAGELENGTH(60) 

BUILD:  DO? 

/*  COBOL  COMPILER  -  BUILD  */ 

/*  NORMALLY  LOCATED  AT  102H  */ 

/*  GLOBAL  DECLARATIONS  AND  LITERALS  */ 

/♦  THIS  PROGRAM  TAKES  THE  CODE  OUTPUT  FROM  THE  COBOL 
COMPILEP  AND  BUILDS  THE  ENVIRONMENT  FOR  THE  COBOL 
INTERPRETER  */ 


DECLARE 

LIT 

TRUE 

ADD? 

BASE 

B$ADDR 

B$BTTE 

BOOT 

BUFF SEND 

CHAR 

CODESCTR 

CSADDR 

C$BTTE 

CODFSNOTSSET 

CURSSYM 

DCL 

EXT 

FALSE 

FCB 

FCBSBTTE 

FCB$BYTE$A 

FILFSTTPE  (*) 

FOREVER 

FREESSTORAGE 

HASHSMASE 

I 

INTERPSADDRESS 
INTERPSCONTENT 
I NTERP$FCB(33 ) 

ISBTTE 

HISOFFSET 


LITERALLY 

LIT 

ADDRESS 

ADDRESS, 

BASED 

BASED 

LIT 

LIT 

BASED 

ADDRESS, 

EASED 

BASED 

BYTE 

ADDRESS, 

LIT 

LIT 

LIT 

ADDRESS 
BASED  FCB 
EASED  FCB 
BYTE 
LIT 

ADDRESS, 

BYTE 

BYTE, 

ADDRESS 

BASED 

BYTE 

BASED 

ADDRESS 


'LITERALLY', 

'1'. 

IN ITIAL ( 100H) , 

BASE  ADDRESS. 

BASE  (4)  BYTE, 

'0', 

'100H  ' , 

ADDR  BYTE, 

CODESCTR  ADDRESS, 
CODE$CTR  BYTE, 

IN ITIAL (TRUE) , 

'DECLARE', 

'08H ' , 

'0', 

IN  IT IAL( 5CH) , 

BYTE. 

(33)  BYTE, 

DATA( '.CIN$'), 

'WHILE  TRUE', 

INITIAL(0FH), 

IN ITIAL(3500H) , 
INTERPSADDRFSS  ADDRESS, 
INITIALS,  'CINTERP  COM', 
0,0. 0.0), 

INTERP$ ADDRESS  (2)  BYTE, 
IN ITIAL (00H ) , 
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LOV$ OFFSET 

LOADED 

MAXSMRMORY 

NEXTSSYM 

NEXT$SYM$ENTBY 

POINT 

COLLISION 

PROC 

PROC^NAME (8 ) 
READER$LOCAT ION 
STP 

SUB$FLAG 

SYMBOL 

SYMBOL$ADDR 

TOP*OF*MEMORY 


ADDRESS  INITIAL(00H ) , 

LIT  '101', 

ADDRESS  IHITIAL(1C80B) , 

ADDRESS, 

BASED  NXXT$SYM  ADDRESS. 


ADDRESS, 

BASED  POINT 
LIT 
BYTE, 

ADDRESS 
LIT 
BYTE 
BASED  CUR$SYM 
BASED  CUR$SYM 
ADDRESS 


ADDRESS, 

'PROCEDURE', 

IN ITIAL(1C80H) , 

'06H ', 

INITIAL  (FALSE) , 
(1)  BYTE, 

(1)  ADDRESS, 

I NIT IAL  (0B100E ) 5 


MON1:  PROC (F, A)  EXTERNAL? 

DCL  F  BYTE,  A  ADDRESS ? 

END  MONi; 

M0N2:  PROC(F,A)  BYTE  EXTERNAL,* 
DCL  F  BYTE,  A  ADDRESS.* 

END  M0N2; 


PRINT$CHAR:  PROC(CEAR); 

DCL  CHAR  BYTE? 

CALL  MONI  (2, CHAR); 

END  printschar? 

CRLF:  PROC? 

CALL  PRINT$CRAR(13)? 

CALL  PR IN T$ CHAR (10) ? 

END  CRLF? 

PRINT:  PROC (A)? 

DCL  A  ADDRESS? 

CALL  MONI (9 , A ) ? 

END  PRINT? 

PRINTSNAME:  PROC (ADDR) ? 

DCL  ADDR  ADDRESS? 

BASE  *  ADDR? 

I  »  255? 

CALL  CRLF? 

DO  VHILE(B$BYTE(I  :•  I  ♦  1)  <>  '  ')  AND  (I  <  8) 
CALL  PRINT$CFAR(B$BYTE(I ))? 

END? 

END  PRINT$NAME? 


OPEN:  PROC (A)  BYTE? 
DCL  A  ADDRESS? 


RETURN  M0N2 (15  ,A ) » 

END  open; 

CLOSE:  PROC(FCB); 

DCL  FCB  ADDRESS; 

IE  M0N2 (16, ECB )  =  255  THEN 

do; 

call  crle; 

CALL  PRINT(.( 'CLOSE  ERROR  ON  MODULE 
CALL  PRINT$NAME(FCB  +  1),* 

end; 

END  close; 

REBOOT:  PROC; 

ADDR  =  BOOT; 

CALL  addr; 

END  REBOOT,* 

FATAL$ERROR:  PROC (REASON ) ; 

DCL  REASON  ADDRESS; 

CALL  crle; 

CALL  PRINT$CHAR(HIGH(REASON)); 

CALI  PRINTS CHAR (LOW  (REASON))? 

CALL  PRINT$NAME(FCB  +  1); 

CALL  PPINT(.FILE$TTPE); 

CALL  reboot; 

END  fatal$error; 

move:  PROC (from,  dest,  count); 

DCL  (FROM, DEST, COUNT)  ADDRESS, 

(F  BASED  FROM.D  BASED  DEST)  BITE? 

DO  WHILE(COUNT  :=  COUNT  -DO  0FFFFH? 

D  =  f; 

FROM  =  FROM  ♦  1? 

DEST  =  DEST  +  1? 

end; 

END  move; 

FILL:  PROC(ADDR, CHAR, COUNT)? 

DCL  ADDR  ADDRESS, 

(CHAR  .COUNT, DEST  BASED  ADDR)  BITE? 

DO  WHILE  (COUNT  :»  COUNT  -1)0  0FFH ? 

DEST  *  char; 

ADDR  *  ADDR  +  1? 

END? 

END  fill; 

GETS CHAR:  PROC  BITE? 

I?  (ADDR  :*  ADD?  +  1)  >=  BUFFSEND  THEN 
DO? 


IF  MON2(20,FCB)  O  0  THEN 


CALL  CRLF? 

CALL  PRINT(.('END  OF  INPUTS') )J 
CALL  REBOOT,* 

end; 

A DDR  =  fi0H » 

end; 

RETURN  CHAR; 

end  getschar; 

NEXTSCHAR:  PROC; 

char  *  getschar; 
end  nextschar; 

STORE:  PROC (COUNT); 

DCL  COUNT  BITE; 

IF  CODESNOTSSET  THEN 

do; 

call  crlf; 

CALL  PRINK.  ( 'CODE  ERRORS')); 

CALL  nextscear; 
return; 

end; 

do  i  *  i  to  count; 

CSBTTE  =  CBAR; 

call  nextscfar; 
codesctr  =  CODESCTR  ♦  i; 

end; 

end  store; 

INITSLOADSTABLE:  PROC; 

FREESSTORAGE  =  .MEMORY? 

CALL  FILL (FREESSTORAGE, 2, 34) » 

NEXTSSTM  =  FREESSTORAGE  +  32; 

NSXT$SYM$ENTRY  *  0; 

end  initsloadstablf; 

BUILDSSYMBOL:  PROC; 

DCL  TEMP  ADDRESS; 

TEMP  *  NEXTSSTM? 

IF  (NEXTSSTM  :=  .STMBOL(17))  >  MAXS MEMORY  THEN 
CALL  FATAL$ERROR( 'PS') 5 
CALL  FILL(TEMP,0,17); 

END  BUILDSSYMBOL? 

MATCH:  PROC? 

DCL  (HOLD, I )  BYTE? 

HOLD  »  0? 

DO  I  *  TO  7? 

HOLD  ■  HOLD  +  PROC$NAME( I ) ? 

end; 

POINT  ■  FREESSTORAGE  +  SHL( (HOLD  AND  HASHSMASK) , 1 ) ? 


do  forever; 

IF  COLLISION  «  0  THEN 

do; 

CUR$STM , COLLISION  =  NSXT$STM; 

call  build$stmbol; 

DO  I  -  0  TO  7; 

SYMBOLd  ♦  8)  =  PROC$NAMF(  I ) » 

end; 

return; 

end; 

ELSE 

co; 

CUR$SYM  =  COLLISION; 

I  =  0; 

DO  VEILS  SYMBOLd  +  8)  =  PROC$NAME(I); 
IF  (I  :*  I  +  l)  >  ?  THEN 

do; 

CUR$SYM  «  collision; 
return; 
end; 

end; 

end; 

point  *  collision; 

end; 

end  match; 

STUFF:  PROC,* 

DCL  (HOLD .TEMP)  ADDRESS; 

HOLD  =  STMBOL$ADDR(l); 

BASE  -  .temp; 

B$BTTE(0)  »  GETSCHAR; 

b$btte(i)  -  get$char; 

STMBOLiADDH(l)  «  CODE$C?R  ♦  TFMP  -  INTERP$ADDRESS  J 
DO  WHILE  HOLE  <>  0; 

BASE  *  hold; 
fold  *  bsaddr; 

DO  I  *  1  TO  3; 

b$addr  «  stmbol$addr(i  ); 

BASE  »  BASE  +  2; 

end; 

end; 

CODEiCTR  *  STMBOLiADDR ( 1 ) J 
END  STUFF; 

COMPUTS$OFFSETS:  PROC; 

DCL  TEMP  ADDRESS; 

BASE  ■  .temp; 

B$BYTE(0 )  =  GET$CHAR; 

B$BTTE(1)  *  GETSCHARJ 

HI$OFFSET  *  HISOFFSET  ♦  (TOP$OF$MEMORY  -  TEMP  +  1); 
LOW$OFFSET  -  CODE$CTR  -  INTSRP$ADDRESS  -  2; 


END  COMPUTES OFFSETS ! 

SUBR:  PROC; 

DC!  I  BITE* 

CALL  STORE(l); 

DO  I  *  0  TO  ?; 

PROC$NAME(I)  »  char; 
call  nextschar; 

end; 

call  match; 

DO  I  =  1  TO  3; 

C$ADDR  =  STMPOL$ADDR(I); 
CODESCTR  »  CODESCTR  +  2i 

end; 

IF  SYMBOL (LOADED)  =  0  THEN 

STMBOL$ADDR(l )  =  CODESCTR  -  6? 
END  subr; 

GOSBEPENPINC:  PROC; 

CALL  STORE(l); 

CALL  STORE(SRL (CHAR , 1 )  *  4); 

END  gosbepending; 

PARAMETERS:  PROC f 
CALL  STORE(l); 

CALL  S TORE (SHL( CHAR, 1 )  +  2); 

END  parameters; 

BACKSSTUFF:  PROC J 

DCL  (HOLD, STUFF)  ADDRESS; 

BASE  *  .hold; 

DO  I  *  0  TO  3; 

B$BYTE(I)  »  GETSCHAR; 

end; 

do  forefer; 

BASE  *  HOLD  ♦  LOW$OFFSET; 

hold  »  bsaddr; 

BSADDR  *  STUFF? 

IF  HOLD  »  0  THEN 

do; 

CALL  NEXTSCHAR; 

return; 

end; 

end; 

end  backsstuif; 

INITIALIZE:  PROC; 

DCL  (COUNT, WHERE, HOWSMANT)  ADDRESS 
BASE  -  .where; 

DO  I  *  0  TO  3J 

BSBTTFd)  »  GETSCHAR; 
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end; 

IF  WHERE  >  T0P$0F$MEM0RY  -  HI $OFFSET  THEN 
BASE  »  WHERE  -  HI $OFFSET  -  18 

ELSE 

BASE  *  WHERE  ♦  LOW$OFFSET  -  18 
DO  COUNT  «  1  TO  how$kany; 

B$BTTE(COUNT)  *  GETSCHAR; 

end; 

CALL  next$cfar; 
end  initialize; 

TERMINATE:  PROC; 

DCL  I  BYTE,  TEMP  ADDRESS; 

IF  SUB$FLAG  THEN  C$BYTE  -  EXT; 

ELSE  CSBYTE  «  STPJ 
CODE$CTR  *  CODE$CTR  +  l; 

I  -  0IFH; 

CALL  PRINT$NAME(FCB  +  1); 

CALL  PRINT(.('  LOADED*')); 

subsflag  »  false; 

DO  I  *  0  TO  15; 

POINT  *  FREESTORAGE  +  2  *  i; 

DO  WHILE  COLLISION  <>  08 
CURSSYM  *  collision; 

IF  SYMBOL(LOADED)  =  0  THEN 

do; 

CODE$NOT$SET ,S YMBOl ( LOADED )  ,SUB*FLAG 

true; 

CALL  COMPUTE*OFFSETSJ 
SYMBOL* ADDR(2)  =  LOW$OFFSET; 
SYM30L$ADDR(3)  *  hi$ofeset; 

CALL  CLOSE(FCB); 

CALL  MOVE( .SYMB0L(8 ) ,FCB  +  l,e)8 
?CB$BYTE$A(32)  =  08 
CALL  FILL(FCB  «■  12,0,4); 

ADDR  ■  10018 

IF  OPEN (FCB)  =  255  THEN 

CALL  FATALSERBOR('OP'); 

CALL  NEXT$CHAR8 

return; 

end; 

point  »  collision; 

end;  /*  DO  WHILE  COLLISION  <>  0  */ 

end;  /*  do  i  ■  o  to  15  */ 

END  terminate; 

START*CODE:  PROCJ 

code*not$set  »  false; 

IF  SUB$FLAG  THEN  CALL  STUFF; 

ELSE 


I$BYTE{0 )  »  GET$CHAR  J 
I$BYTE(1 )  *  GET$CHAR» 
C0DE$CTR  =  INTERP$CONTENT; 

END? 

CALL  NEXT$CHAR; 

END  START$CODE* 

BUILDS  PROCJ 
DCL 


F2 

LIT 

'9' 

F3 

LIT 

*10 

F4 

LIT 

'22 

F5 

LIT 

'26 

F6 

LIT 

'34 

F7 

LIT 

'41 

F8 

LIT 

'51 

F9 

LIT 

'51 

F10 

LIT 

'56 

Fll 

LIT 

'62 

F12 

LIT 

'63 

F13 

LIT 

'63 

SBR 

LIT 

'64 

GDP 

LIT 

'65 

PAR 

LIT 

'66 

I  NT 

LIT 

'6? 

BST 

LIT 

'68 

TER 

LIT 

'69 

SCD 

LIT 

'70 

DO  FOREVER: 


IF 

CHAR 

< 

F2 

THEN 

CALL 

store(i); 

ELSE 

IF 

CHAR 

< 

F3 

THEN 

CALL 

ST0RE(2); 

ELSE 

IF 

CHAR 

< 

F4 

THEN 

CALL 

STORE (3); 

ELSE 

IF 

CHAR 

< 

F5 

THEN 

CALL 

STORE(4); 

ELSE 

IF 

CHAP 

< 

F6 

THEN 

CALL 

STORE (5)J 

ELSE 

IF 

CHAR 

< 

F7 

THEN 

CALL 

STPRE(6) * 

ELSE 

IF 

CHAR 

< 

F8 

THEN 

CALL 

STORE(7); 

ELSE 

IF 

CHAR 

< 

F9 

THEN 

CALL 

store (e); 

ELSE 

IF 

CHAR 

< 

F10 

THEN 

CALL 

STORE (9) * 

ELSE 

IF 

CHAR 

< 

Fll 

THEN 

CALL 

STORK  10); 

FLSE 

IF 

CHAR 

< 

F12 

THEN 

CALL 

STORKll  ); 

ELSE 

IF 

CHAR 

< 

F13 

THEN 

CALL 

STORE (12): 

FLSE 

IF 

CHAP 

< 

SBR 

THEN 

CALL 

ST0RK13); 

FLSE 

IF 

CHAP 

S 

SBR 

THIN 

CALL 

subr; 

ELSE 

IF 

CHAR 

m 

GDP 

THEN 

CALL 

go$dep ending; 

FLSE 

IF 

CHAR 

m 

PAR 

THEN 

CALL 

parameters; 

ELSE 

IF 

CHAR 

9 

BST 

THIN 

CALL 

back$stu?f; 

ELSE 

IF 

CHAR 

9 

INT 

TEEN 

CALL 

initialize; 

ELSE 

IF 

CHAR 

m 

TER 

TEEN 

do; 

CALL 

TERMINATE* 
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I?  MOT  SUB$FLAG  THEN 

do; 

CALL  COMPUTE$OFFSETS; 
CALL  CLOSE(FCB)? 

return; 

end; 

end; 

ELSE  IT  CHAR  *  SCD  THEN  CALL  START$CODF; 
FLSE 

do; 

call  crlf; 

CALL  PRINT( . ( 'LOAD  ERROR$  ' ) )  J 
CALL  next$char; 

end; 

fnd; 

end  build; 

/*  PPOGRAM  EXECUTION  STARTS  HERE  V 


CALL  crlf; 

CALL  PRINT(.('NPS  MICRO-COBOL  LOADER  TERS  2.0$')); 
FCB$BTTE$A(32)  *  0; 

CALL  MOVE( .('CIN',0, 0,0,0), FCB  +  9.7); 

IF  OPEN ( FCB)  *  255  THEN 

do; 


CALL  crlf; 

CALL  PR INT$NAME(FCB  +  1); 
CALL  PRINT(.FIIB$TYPE); 
CALL  reboot; 


end; 

call  next$cear; 
call  init$load$table; 
call  build; 

CALL  MOVF(  .INTERP$FCB,FCB,33); 

FCB$BYTE$A (32 )  -  0? 

IF  OPEN (FCB)  -  255  THEN 

do; 

call  crlf; 

CALL  PRINT(.( 'CINTERP.COM  NOT  FOUND 
CALL  reboot; 


end; 

CALL  M0VE(READER$L0CATI0N .  80H.  80H); 
CALL  MO¥I( .HI$OFFSET,0TCH,4); 

A DDR  -  80H5 

CALL  ADDR;  /*  BRANCH  TO  80H  */ 


$')); 


end; 
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COMPUTER  LISTING  TOR  MODULE  INTRDR  NPS  MICRO-COBOL 

$  TITLE('NPS  MICRO-COBOL  COMPILER  INTRDR')  PAGEVIDTH(80) 
PAGELENGTH(60) 

INTRDR:  DO? 


/*  COBOL  COMPILER  -  INTRDR  */ 

/*  NORMALLY  LOCATED  AT  80  H  */ 

/*  GLOBAL  DECLARATIONS  AND  LITERALS  */ 

/*  THIS  PROGRAM  IS  CALLED  BT  THE  BUILD  PROGRAM  APTER 
CINTERP.COM  HAS  BEEN  OPENED,  AND  READS  THE  CODE  INTO  MEMORY 

*/ 


DECLARE 

LIT  LITERALLY 
DCL  LIT 
I  ADDRESS 

INTERP  ADDRESS 
PROC  LIT 
START  LIT 


'LITERALLY', 
'DECLARE', 
INITIAL  (0080H), 
INITIAL( 100H) , 
'PROCEDURE', 
'10OH'? 


MON  1 :PROC (P, A )  EXTERNAL; 

DCL  P  BYTE.  A  ADDRESS? 

END  MONi; 

MON 2:  PROC (P, A)  BYTE  EXTERNAL? 

DCL  E  BYTE,  A  ADDRESS? 

END  M0N2? 


DO  VHILE  1? 

CALL  MONI  (26,(1  :=  I  +  0080H))?  /*  SET  DMA  ADDRESS  */ 
IP  M0N2  (20, SCR)  <>  0  THEN 
CALL  INTERP? 

END? 

END? 
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COMPUTE®  LISTING  FOR  MODULE  DECODE  NPS  MICPO-COBOL 


$  TIUK'NPS  MICRO-COBOL  COMPILE®  DECODE')  PAGFWI DTH ( 80) 
?AGELENGTE<60) 

DECODE:  DO? 


/*  COBOL  COMPILER  -  DECODE  */ 
/*  NORMALLY  LOCATED  AT  103E  V 


/*  GLOBAL  DECLARATIONS  AND  LITERALS  */ 

/*  THIS  PROGRAM  TAKES  THE  COrE  OUTPUT  FROM  THE  COBOL 
COMPILER  AND  CONVERTS  IT  INTO  A  READABLE  OUTPUT  TO 
FACILITATE  DEBUGGING  */ 


DECLARE  DCL 
LIT 
A  DDR 

BUFFSEND 

BYTESCOUNT 

BYTE$HI 

BYTES LOW 

CHAR 

CAADDR 

FCB 

EC3SBYTE 

FILESTYPE(*) 

I 

PROC 


LITERALLY 

LITERALLY 

ADDRESS 

LIT 

ADDRESS 

BYTE, 

BYTE, 

BASED  ADD?. 

BASED  ADDR 

ADDRESS 

BASED  FCB  (1) 

BYTE 

BYTE, 

LIT 


'DECLA  RE', 
'LITERALLY', 
INITIAL  (100"), 
'0FFE', 
INITIALS), 


BYTE, 

ADDRESS. 
INITIAL  ( 5CH ) , 
BYTE, 

DATA  ('CIN'), 
'PROCEDURE'* 


MON1:  PROC  (F,A)  external; 

DCL  F  BYTE,  A  ADDRESS? 
END  MON1J 


MON 2:  PROC  (F,A)  BYTE  EXTERNAL; 

DCL  F  BYTE,  A  ADDRESS? 

END  M0N2? 


BOOT:  PROC  EXTERNAL; 
END  BOOT? 


PRINTACHARs  PROC (CHAR)? 
DCL  CHAR  BYTE? 

CALL  MCN1 (2 , CHAR) ? 
END  PRINTACHAR? 


CHIP:  PROC; 

CALI  PRINT$CBAR(13); 
CALL  PRINT$CHAR(10) ; 
END  CHLPJ 


P:  PROC(ADDl); 

DCL  ADD1  ADDRESS,  C  BASED  ADD1  (1)  BYTE? 
CALL  crlf; 

DO  I  *  0  TO  2? 

CALL  PRINT SC HAR(C(I)); 

end; 

CALL  PRINT$CHAR( '  '); 

END  p; 

GETSCHAR:  PROC  BYTE; 

I?  (ADDR  :=  ADDR  ♦  l)  >  BUPFSEND  THEN 

do; 

IP  MON2(20,FCB)  <>  0  TEEN 

do; 

CALL  P(.('END')>; 

CALL  boot; 

end; 

ADDR  -  e0HJ 

end; 

RETURN  CHAR; 

END  GETSCHAR? 


D$CHAR:  PROC  (OOTPUT$BYTE ) J 
DCL  0UTPUT$3YTE  BYTE; 

IP  OUTPUTSBYTE  <  10  THEN 

CALL  PR  I NTSCHAR( OUTPUTS BYTE  ♦  30H); 

ELSE 

CALL  PR  I NT$CFAR( OUTPUTS BYTE  ♦  3?H)5 
END  dschar; 


Dj  PROC  (count); 

DCL( COUNT ,J )  address; 
do  j-i  to  count; 

CALL  D$CHAR(SHR(GETSCHAR,4) ); 
CALL  DSCHAR (CHAR  AND  0PH )  J 
CALL  PRINT$CHAR('  '); 

end; 
end  d; 


PRINTSREST:  PROC; 
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9\ 

'10', 

'22', 

'26', 

'34', 

'41', 

'51', 

'51', 

'56', 

'62', 

'63', 

'64', 

'63', 

'65', 

'66', 

'67', 

'66', 

'69', 

'70'; 


I?  CPAR 
IF  CHAR 
IF  CHAR 
IF  CPAR 
IF  CHAR 
IF  CHAR 
IF  CHAR 
IF  CHAR 
IF  CHAR 
IF  CHAR 
IF  CHAR 
IF  CHAR 
IF  CHAR 
IF  CEAR 
IF  CHAR 

do; 


<  ?2 

<  F3 

<  F4 

<  F5 

<  F6 

<  F7 

<  F8 

<  F9 

<  *10 

<  Fll 

<  F12 

<  FI  3 

<  SBR 

*  SBR 

*  GDP 


THEN 

THEN 

THEN 

THEN 

THEN 

THEN 

THEN 

TEEN 

THEN 

THEN 

THEN 

THEN 

THEN 

TEEN 

THEN 


return; 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 
do;  call 


d(i); 

D(2); 
D(3) ; 
B(4); 
d(5); 
D(6); 
r(7) ; 

d(8); 

d(9); 
B(  10 ) 
D(  11 ) 
D(  12  ) 
D(8); 


RETURN 
RETURN 
RETURN 
RETURN 
RETURN 
RETURN 
RETURN 
RETURN 
RETURN 
;  RETURN 
I  RETURN 
I  RETURN 

return; 


end; 

end; 

end; 

end; 

end; 

end; 

end; 

end; 

ent; 

end; 

end; 

end; 

end; 


end; 

IF  CHAR 

do; 


end; 

IF  CHAR 

do; 


CALL  D(l); 

CALL  D(SEL(CHAR,1)  ♦  3); 

return; 

I 

»  PAR  THEN 
CALL  D (1 ) ; 

CALL  D(SHL{CHAR , 1 )  +  1); 

return; 

i 

»  INT  THEN 

BITESCOUNT  ■  0i 
CALL  D(3); 


•3 / 


BYTE$LOW  -  CEAP.J 
CALL  o(i); 

BYTESHI  «  CHAR; 

BYTE$CO0NT  *  BYTE$HI * 

BYTE$C0UNT  =  SHL (BYTES COUNT ,8 )  +  BYTFSLOWJ 
CALL  D(BYTESCOUNT); 

RETURN ; 

end; 

IF  CHAR  *  BST  THEN 

do; 

CALL  0(4); 

RETURN ; 

end; 

IF  CHAR  *  TER  THEN 

do; 

CALL  0(2); 

CALL  P(.('END')); 

CALL  boot; 

end; 

IF  CHAR  =  SCO  THEN 

do; 

CAU  0(2); 
return; 

ENr; 

CALL  P(.('XXX')}; 

END  P5INT$REST; 


/*  PROGRAM  EXECUTION  STARTS  HERE  */ 

FCB$BYTE(32) ,  FCB$BYTE(0)  -  e; 

DO  I»0  TO  2; 

FCB$BYTE( I+9)*FILE$TYPE(I ) ; 

end; 

IF  M0N2(15fFCB)»255  THEN  DO;  CALL  P(.('ZZZ'))J 

CALL  BOOT;  end; 


DO  WHILE  i; 

IT  GET$CHAR  <»  70  THEN  DO  CASE  CHAP; 
;  /*  CASE  0  NOT  USED  V 

CALL  P(.('ADD')); 

CALL  P(.('SUB'))J 
CALL  P(.('MUL')); 

CALL  P(.('DI?')); 

CALL  P(.('NEG'))? 

CALL  P( .('STP')); 

CALL  P(.('STI'j); 

CALL  P(.('EXT'))i 
CALL  P(.('RND')); 

CALL  P(.('RET')); 
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cm  p( 

CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  F( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P( 
CALL  P< 
CALL  P( 
CALL  P( 
CALL  P< 


.  ('CLS'))i 

.('  SER'))! 

.  ('BRN')): 

.('OPN'))i 

.('0P1')) 

.('0P2'))! 

.('RGT')); 

.('RLT'))! 

.('REQ'))! 

.('INV'))i 

. ( 'EOR  ' ) ) 

.('PAG'))! 

.('ACC')) 

.('STL')): 

. ( 'LDI  ' ) ) 

.('LIS')) 

.('EEC')) 

. ( 'STO  ' ) )  i 
. ( 'ST1 ' ) ) 

. ( 'ST2  ') ) 

.  (  'ST3' ) ) 

. ( 'ST4  '  ) ) 

.('ST5')) 

.('LOD')) 

.('LDI')) 

. ( 'LD2  ') ) 

.('LDS')V 

,('LD4')) 

. ( 'LD5  ' ) ) 

.('LD6')) 

.('PER')) 

.  ( 'CID') ) 

•  ( 'CKS  ' ) ) 
.('CAL')) 
. ( 'RWS  ' ) ) 
.  ( 'DLS  ' ) ) 

•  ( 'RDT' ) ) 
.('WTf ')) 
.('HU')) 
.('ML')) 
.('SCR')) 
.('SGT')) 
.  ( 'SLT') ) 
.('SEO')) 
.('MO?')) 
. ( 'RRS  ' ) ) 

•  ( 'WRS  ' ) ) 

•  ( 'RRR' ) ) 
.('MR')) 
. ( 'RWR') ) 
. ( 'DLR') ) 
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CALL  P(.('MED')); 

CALL  P(.('MNE'))J 
CALL  P(.('SBR')); 

CALL  P(.('GDP')); 

CALL  P(.('PAR')); 

CALL  P(.('INT'))J 
CALL  P(.('BST')); 

CALL  P(.('T7R')); 

CALL  P(.('SCE'))J 
END?  /*  0?  CASE  STATEMENT  V 
CALL  PRINTSRESTJ 
end;  /*  END  0T  DO  WHILE  */ 

end; 


5 RAMMER  FOR  PART  ONE  NPS  MICRO-COBOL 


OPTIONS  (BN?  TABLES  LALR  AINPUT  EXTRAT  NOGPOST  COMPACT) 


1 

2 

2 

3 

4 

5 

6 

7 

8 
9 

10 

11 

12 

13 

14 

14 

15 

16 
16 

17 

18 
19 

19 

20 
21 
22 
22 

23 

24 

25 

26 

27 

28 

29 

30 

31 

32 

33 

34 

35 

36 

37 

38 

39 

40 


<PROC,RAM>  <ID-DIV>  <E-DIV>  <D-DIV>  PROCEDURE 
<ID-DIV>  ::*=  IDENTIFICATION  DIVISION  .  PROGRAM-ID  . 

<COMMENf>  .  <ID-LIST> 

<ID-LIST>  <AUTH>  <INS>  <DATE>  <SEC> 

<'ACTF>  AUTHOR  .  <COMMENT>  . 

<EMPTT> 

<INS>  INSTALLATION  .  <COMMENT>  . 

<EMPTT> 

<DATE>  =  DATE-WRITTEN  .  <COMMENT>  . 

<EMPTT> 

^SEO  SECURITY  .  <COMMENT>  . 

<EMPTT> 

<COMMENT>  <INPUT> 

<COMMENT>  <INPUT> 

<E-DIV>  ENVIRONMENT  DIVISION  .  CONFIGURATION 

SECTION  .  <SRC-OBJ>  <I-0> 

<EMPTT> 

<SRC-03J>  SOURCE-COMPUTER  .  <COMMENT>  <DE3UG>  . 

OBJECT-COMPUTER  .  <COMM?NT>  . 
<DEBUG>  DEBUGGING  MODE 
<EMPTY> 

<I-0>  INPUT-OUTPUT  SECTION  .  FILE-CONTROL  . 

<file-control-list>  <IC> 

<EMPTY> 

<F I LE-C 0 NTROL-L I S T>  =  <FILE-CONTROL-ENTRY> 

<TILE-CONTROL-LIST> 

<FI LE-C ON  TRO  L-EN  TRY  > 

<EILE-CONTROL-ENTRY>  SELECT  <ID>  <ATTRIBUTE-LIST> 
<ATTRIBUTE-LIST>  :s=  <0NE-ATTRI3> 

<ATTRIBUTE-LIST>  <0NE-ATTPI3> 
<ONE-ATTRIB>  ORGANIZATION  <ORG-TYPE> 

ACCESS  <ACC-TYPE>  <RELATIVE> 

ASSIGN  <INPUT> 

<ORG-TYPE>  SEQUENTIAL 

RELATIVE 
INDEXED 

<ACC-TYPE>  SEQUENTIAL 

RANDOM 

<RELATIVE>  RELATIVE  <ID> 

<EMPTY> 

<IC>  I-O-CONTROL  .  <SAME-LIST> 

<SMPTY> 

<SAME-LIST>  s :■  <SAME-ELEMENT> 

<SAME-LIST>  <SAME-ELEMENT> 
<SAME-ILEMENT>  SAME  <ID-STRING>  . 


41 

42 

43 

43 

44 

45 

46 

47 

48 

48 

49 

50 

51 

52 

53 

54 

55 

56 

57 

58 

59 

60 
60 
61 
62 

63 

64 

65 

65 

66 
66 

67 

68 

69 

70 

71 

72 

73 

74 

75 

76 

77 

78 

79 

80 
81 
82 

83 

84 

85 

86 


<ID-S TRING>  : s=  <ID> 

<ID-STRING>  <ID> 

<D-DIV>  DAT*  DIVISION  .  <FILE-SECTION >  <'WORK> 

<LINK> 

<FILE-SECTION>  =  FILE  SECTION  .  <FILE-LIST> 

<EMPTY> 

<FILE-IIST>  <FILES> 

<FILE-LIST>  <FILES > 

<FILES>  FD  <ID>  <FILE-C0NTR0L>  . 

<RECORD-DESCRIPTION> 

<FILE-CONTROL>  <FILE-LST> 

< EMPTY > 

<FILE-LST>  <FILE-ELEMENT> 

<FILE-LST>  <FILE-ELEMENT> 

<FI LE-ELEMEN T>  =  BLOCK  <INTEGER>  RECORDS 

RECORD  <REC-COUNT> 

LABEL  RECORDS  STANDARD 
LABEL  RECORDS  OMITTED 
7AL0E  OF  <ID-STRING> 
<REC-COUNT>  =  <INTEGER> 

<INTEGER>  TO  <INTEGER> 

<WORK>  s :*  WORKING-STORAGE  SECTION  . 

<RECORD-DESCRIPTION> 

<EMPTT> 

<LI NK>  LINKAGE  SECTION  .  <RECORD-DFSCRIPTION> 
<EMPTT> 

<RECORD-DESCRIPTION>  s:»  <LEVEL-ENTRY> 

<HECORD-DESCRIPTION> 

<LEVEL-ENTRY> 

<LFVEL-ENTRY>  <INTEGER>  <DATA-ID>  <REDEFINES> 

<DATA-TYPE>  . 

<DATA-ID>  <ID> 

FILLER 

<REDBFINES>  REDEFINES  <ID> 

<EMPTY> 

<DATA-TYPE>  :s=  <PROP-LIST> 

<EMPTY> 

<PRO?-LIST>  <DATA-FLEMENT> 

<PROP-LIST>  <DATA-ELEMENT> 

<DATA-ELEMENT>  =  PIC  <INPUT> 

USAGE  COMP 

USAGE  COMP-3 

USAGE  COMPUTATIONAL 

USAGE  DISPLAY 

SIGN  LEADING  <SEPARATE> 

SIGN  TRAILING  <SEPARATF> 

OCCURS  <INTEGER>  INDEXED  <ID> 
OCCURS  <INTEGIR> 

SYNC  <DIRFCTION> 

VALUE  <LITERAl> 

<DIPECTION>  LEFT 
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87  BIGHT 

88  <EMPTY> 

89  <SEPARATE>  =  SEPARATE 

90  <E«PTY> 

91  <LITERA1>  :s*  <INPOT> 

92  <tIT> 

93  ZERO 

94  SPACE 

95  QUOTE 

96  <I!UTEGFR>  <IMPUT> 

97  <ID>  <INPUT> 


Note  that  the  options  list^eontains  the  item  NOC-POST. 
This  elimenats  the  hoal  symbol  from  being  added  to 
the  grammer  of  part  one.  In  part  two  the  hoal  symbol  is 
used  as  an  end  of  file  symbol  (EOF). 


GRAMMES  FOR  PART  TWO  NPS  MICRO-COBOL 


OPTIONS  (BN?  TABLES  LALR  AINPUT  EXTRAT  COMPACT) 


1 

<P-DIV> 

PROCEDURE  DIVISION  <USING>  .  <PROC-BODY> 

2 

<USING> 

USING  <ID-STRING> 

3 

<EMPTT> 

4 

<ID-STRING> 

<ID> 

5 

<ID-STRING>  <ID> 

6 

<PROC-BODY> 

•.:«  <PARAGRAPH> 

7 

<PROC-BODT>  <PARAGRAPH> 

8 

<PARAGRAPH> 

<ID>  . 

9 

<ID>  .  <SENTENCE-LIST> 

10 

<ID>  SECTION  . 

11 

<SENTENCE-LIST>  <SENTENCE>  . 

12 

<SENTENCE-LIST>  <SENTENCE>  . 

13 

<SENTENCE>  i 

!*»  <IMPERATIVE> 

14 

<CONDITIONAL> 

15 

ENTER  <ID>  <OPT-ID> 

16 

<IMPERATIVE> 

ACCEPT  <SUBID> 

17 

<ARITHMETIC> 

18 

CALL  <CALL-LIT>  <USING> 

19 

CLOSE  <CLOSE-LST> 

20 

<FILE-ACT> 

21 

DISPLAY  <DISPLAY-LST> 

22 

DISPLAY  <DISPLAY-LST>  WITH  NO 

22 

ADVANCING 

23 

EXIT  <PROGRAM-ID> 

24 

GO  <ID> 

25 

GO  <ID-STRING>  DEPENDING  <ID> 

26 

MOVE  <LIT/ID>  TO  <SUBID> 

27 

OPEN  <ACT-LST> 

28 

PERFORM  <ID>  <THRU>  <?INISH> 

29 

STOP  <TERMINATF> 

30 

<CLOSE-LST> 

<ID> 

31 

<CLOSE-LST>  <ID> 

32 

<DISPLAY-LST>  <LIT/ID> 

33 

<DISPLAY-LST>  <LIT/ID> 

34 

<ACT-LST>  :: 

«  <TYPE-ACTION>  <OPEN-LST> 

35 

<ACT-LST>  <TYPF-ACTION>  <OPEN-LST> 

36 

<OPEN-LST>  : 

:*  <ID> 

37 

<OPFN-LST>  <ID> 

38 

<FINISH> 

•  <L/ID>  TIMES 

39 

<STOPCONDITION> 

40 

<VARYING>  <ITERATION>  <STOPCONDITION> 

41 

<EMPTY> 

42 

<STOPCONDITION>  UNTIL  <CONDITION> 

43 

<VARTING>  :: 

-  VARYING  <SUBID> 

44 

<ITSRATION> 

<FROM>  <BY> 
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45 

<FROM> 

FROM  <L/Iir> 

46 

<BT>  BY 

<L/ID> 

47 

<C0NDITI0NAL>  <ARITHMETIC>  <SIZE-ERROR> 

47 

IMPERATIVES 

48 

<FIIE-ACT>  <INVALID>  < IMPERATIVE^ 

49 

<READ-ID>  <SPECIAL>  <IMPEPATIVE> 

50 

<IF-NONTERMINAL>  <CONEITION> 

50 

<IE-LST>  <ELSE>  <I?-tST>  FND- 

51 

<IF-N0NTERMINAL>  CONDITIONS 

51 

<IF-LSTS  END-IF 

52 

<I?-LST>  :: 

=  <STMT-LST> 

53 

NEXT  SENTENCE 

54 

<ELSE> 

ELSE 

55 

<APITHMETIC>  ss»  ADD  <ADD-LST>  TO  <SDBID>  <R0UND> 

56 

ADD  <ADD-LST>GIVING  <SU3ID>  <ROUNDS 

57 

DIVIDE  <L/ID>  INTO  CUBIDS  <ROOND> 

58 

DIVIDE  <L/ID>  BY  <SU3IDS  GIVING 

58 

<SUBID>  <ROUND> 

59 

DIVIDE  <l/ID>  INTO  <TSUB!D^  GIVING 

59 

<SUBID>  <ROUND> 

60 

MULTIPLY  <L/ID>  BY  <SUBID>  <ROUNDS 

61 

MULTIPLY  <L/IDS  BY  <SUBID>  GIVING 

61 

<SUBID>  <ROUND> 

62 

SUBTRACT  <SUB-LST>  FROM  <SUBID> 

62 

<ROUND> 

63 

SUBTRACT  <SUB-LST>  GIVING  <SU3ID> 

63 

<ROUND> 

64 

COMPUTE  <SUBID>  «  <ARITH-EXPS 

65 

<ADD-LST>  : 

:»  <L/ID> 

66 

<ADD-LST>  <L/ID> 

67 

<SUB-LST>  : 

:=  <L/ID> 

68 

<SUB-LST>  <L/ID> 

69 

<ARITH-EXP> 

s  :*  <TERM> 

70 

<ARITH-EXPS  +  <TERM> 

71 

<AFITH-EXP>  -  <TERM> 

72 

♦  <TERM> 

73 

-  <TERM> 

74 

<TEHM> 

<PRIMARY> 

75 

<TERM>  *  <PRIMARY> 

76 

<TERM>  /  <PRI MARYS 

77 

<PRIMARY>  : 

:■  <PRIM-ELEM> 

78 

<PRIMARY>  **  <PRIM-ELEM> 

79 

<’PRIM-ELEM> 

<L/ID> 

80 

(  <ARITH-EXP>  ) 

81 

<EILE-ACT> 

DELETE  <ID> 

82 

REWRITE  <ID> 

83 

WRITE  <ID>  <SPECIAL-ACT> 

84 

<CONDITION> 

s:»  <BTERM> 

85 

<CONDITION>  OR  <BTERM> 

86 

<BTTRM> 

<BPRIM> 

87 

<BTIRM>  AND  <BPRIM> 
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68 

99 

99 

91 

92 

93 

94 

95 

96 

97 

98 

99 
100 
101 
102 

103 

104 

105 

106 

107 

108 

109 

110 
111 
112 

113 

114 

115 

116 

117 

118 

119 

120 
121 
122 

123 

124 

125 

126 

127 

128 

129 

130 

131 

132 

133 

134 

135 

136 

137 

138 


<BPRIM>  :s«  <LIT/ID> 

<LIT/ID>  <NOT>  <COND-TTPB> 

(  <?TERK>  } 

<COND-TYPE>  NUMERIC 

ALPHABETIC 
<COMPARE>  <LIT/ID> 

<NOT>  NOT 

<IMPTT> 

<COMPARE>  GREATER 

LESS 
EQUAL 
> 

< 

m 

<ROUND>  : :«  ROUNDED 
<IMPTT> 

<TERMINATE>  <LITERAL> 

RUN 

<SPECIAL>  <INVALID> 

END 

<OPT-ID>  <SUEID> 

<EMPTY> 

<STMT-LST>  <IMPERATIVE> 

<STMT-LST>  <IMPERATIVE> 
<CONDITIONAL> 

<STMT-LST>  <CONDITIONAL> 

<TERU>  THRU  <ID> 

<EMPTT> 

<INVALID>  :s*  INVALID 

<SIZE-ERR0R>  SIZE  ERROR 

<SPECIAL-ACT>  <VHEN>  ADVANCING  <HOV-MANT> 

<EMPTT> 

<WHEN>  js«  BEFORE 
AFTER 

<HOV-MANT>  <INTEGER> 

PAGE 

<TTPE-ACTION>  INPUT 

OUTPUT 

1-0 

<SU3ID>  <SUBSCRIPT> 

<ID> 

<INTEGER>  <INPUT> 

<ID>  ss«  <INPUT> 

<L/ID>  <INPUT> 

<SUPSCRIPT> 

ZERO 

<SUBSCRIPT>  <ID>  (  <SUBSCRIPT-LST>  ) 
<SUBSCRIPT-LST>  <INPUT> 

<SUBSCPIPT-LST>  t  <INPUT> 

<CALL-LIT>  : t*  <LIT> 

<NN-LIT>  t:-  <LIT> 
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139 

SPACE 

140 

QUOTE 

141 

<LITERAL>  : : 

»  <NN-IIT> 

142 

<INPUT> 

143 

ZERO 

144 

<LIT/ID> 

<L/ID> 

145 

<NN-IIT> 

146 

<PROGRAK-ID> 

<ID> 

14? 

<EMPTT> 

148 

<READ-II»  :: 

«  READ  <ID> 

149 

<IF-NONTERf*INAL>  :s«  IF 

Note  that  the  options  list  does  not  contain  the  item 
NOGPOST.  This  causes  a  goal  symbol  to  be  added  to 
the  grammer  at  the  end  of  production”one.  This  symbol  is 
used  as  the  end  of  file  symbol  (EOF).  Part  one  uses  the 
optional  NOGPOST  to  suppress  the  generation  of  the  goal 
symbol  since  an  EOF  is  not  wanted  at  the  end  of  part  one. 
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